diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 diff --git a/hoppy-generator.cabal b/hoppy-generator.cabal --- a/hoppy-generator.cabal +++ b/hoppy-generator.cabal @@ -1,12 +1,12 @@ name: hoppy-generator -version: 0.5.2 +version: 0.6.0 synopsis: C++ FFI generator - Code generator homepage: http://khumba.net/projects/hoppy license: AGPL-3 license-file: LICENSE author: Bryan Gardiner maintainer: Bryan Gardiner -copyright: Copyright 2015-2018 Bryan Gardiner +copyright: Copyright 2015-2019 Bryan Gardiner category: Foreign build-type: Simple cabal-version: >=1.10 @@ -17,12 +17,21 @@ library exposed-modules: - Foreign.Hoppy.Generator.Language.Cpp + Foreign.Hoppy.Generator.Compiler + , Foreign.Hoppy.Generator.Hook + , Foreign.Hoppy.Generator.Language.Cpp , Foreign.Hoppy.Generator.Language.Haskell , Foreign.Hoppy.Generator.Main + , Foreign.Hoppy.Generator.Override , Foreign.Hoppy.Generator.Spec + , Foreign.Hoppy.Generator.Spec.Callback , Foreign.Hoppy.Generator.Spec.ClassFeature + , Foreign.Hoppy.Generator.Spec.Class + , Foreign.Hoppy.Generator.Spec.Enum + , Foreign.Hoppy.Generator.Spec.Function + , Foreign.Hoppy.Generator.Spec.Variable , Foreign.Hoppy.Generator.Types + , Foreign.Hoppy.Generator.Util , Foreign.Hoppy.Generator.Version other-modules: Foreign.Hoppy.Generator.Common @@ -32,20 +41,27 @@ , Foreign.Hoppy.Generator.Spec.Base , Foreign.Hoppy.Generator.Spec.Conversion default-extensions: - FlexibleContexts + ExistentialQuantification + , FlexibleContexts , FlexibleInstances , FunctionalDependencies , LambdaCase , MultiParamTypeClasses + , ScopedTypeVariables other-extensions: GeneralizedNewtypeDeriving + , UndecidableInstances build-depends: base >=4.7 && <5 - , containers >=0.5 && <0.6 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.7 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5 , haskell-src >=1.0 && <1.1 - , mtl >=2.1 && <2.3 + , mtl >=2.2.1 && <2.3 + , process >=1.2 && <1.7 + , temporary >=1.2 && <1.4 + , text >=1.1 && <1.3 hs-source-dirs: src ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind default-language: Haskell2010 diff --git a/src/Foreign/Hoppy/Generator/Common.hs b/src/Foreign/Hoppy/Generator/Common.hs --- a/src/Foreign/Hoppy/Generator/Common.hs +++ b/src/Foreign/Hoppy/Generator/Common.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -18,18 +18,28 @@ {-# LANGUAGE CPP #-} -- | General routines. +-- +-- Unlike "Foreign.Hoppy.Generator.Util", these are private to the package. module Foreign.Hoppy.Generator.Common ( + filterMaybe, fromMaybeM, fromEitherM, maybeFail, + whileJust_, for, + butLast, listSubst, + listSubst', + doubleQuote, + strInterpolate, zipWithM, - writeFileIfDifferent, -- * String utilities capitalize, lowerFirst, upperFirst, + pluralize, + -- * File utilities + writeFileIfDifferent, ) where #if !MIN_VERSION_base(4,8,0) @@ -38,9 +48,18 @@ import Control.Exception (evaluate) import Control.Monad (when) import Data.Char (toLower, toUpper) +import qualified Data.List as L +import qualified Data.Map as M +import Data.Map (Map) import System.Directory (doesFileExist) import System.IO (IOMode (ReadMode), hGetContents, withFile) +-- | @filterMaybe bad@ converts a @Just bad@ into a @Nothing@, returning all +-- other @Maybe@ values as is. +filterMaybe :: Eq a => a -> Maybe a -> Maybe a +filterMaybe bad (Just value) | value == bad = Nothing +filterMaybe _ mayb = mayb + -- | @fromMaybeM m x = maybe m return x@ fromMaybeM :: Monad m => m a -> Maybe a -> m a fromMaybeM = flip maybe return @@ -53,34 +72,64 @@ maybeFail :: Monad m => String -> Maybe a -> m a maybeFail = fromMaybeM . fail +-- | @whileJust_ gen act@ runs @act@ on values generated from @gen@ until @gen@ +-- returns a @Nothing@. +whileJust_ :: Monad m => m (Maybe a) -> (a -> m b) -> m () +whileJust_ gen act = gen >>= \case + Just x -> act x >> whileJust_ gen act + Nothing -> return () + -- | @for = flip map@ for :: [a] -> (a -> b) -> [b] for = flip map +-- | Drops the last item from the list, if non-empty. +butLast :: [a] -> [a] +butLast [] = [] +butLast xs = take (length xs - 1) xs + -- | @listSubst a b xs@ replaces all @x@ in @xs@ such that @x == a@ with @b@. listSubst :: Eq a => a -> a -> [a] -> [a] listSubst x x' = map $ \y -> if y == x then x' else y +-- | @listSubst' a bs xs@ replaces all @x@ in @xs@ such that @x == a@ with the +-- sequence of items @bs@. +listSubst' :: Eq a => a -> [a] -> [a] -> [a] +listSubst' x xs' = concatMap $ \y -> if y == x then xs' else [y] + +-- | Renders a double-quoted string, enclosing the given characters in double +-- quotes and escaping double quotes and backslashes with backslashes. +doubleQuote :: String -> String +doubleQuote str = '"' : escape str ++ "\"" + where escape s = + if any (\c -> c == '"' || c == '\\') s + then listSubst' '"' "\\\"" $ + listSubst' '\\' "\\\\" s + else s + +-- | Takes a map of strings and a target string, and replaces references to keys +-- enclosed in braces in the target string with their values. Returns a @Right@ +-- with the replaced string on success, and when an unknown key is encountered +-- then a @Left@ with the unknown key. +strInterpolate :: Map String String -> String -> Either String String +strInterpolate values str = case L.findIndex ('{' ==) str of + Nothing -> Right str + Just openBraceIndex -> + let (prefix, termAndSuffix) = splitAt openBraceIndex str + in case L.findIndex ('}' ==) termAndSuffix of + Nothing -> Right str + Just closeBraceIndex -> + let termLength = closeBraceIndex - 1 + term = take termLength $ tail termAndSuffix + suffix = drop (closeBraceIndex + 1) termAndSuffix + in case M.lookup term values of + Nothing -> Left term + Just value -> strInterpolate values $ prefix ++ value ++ suffix + -- | Zips two lists using a monadic function. zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] zipWithM f xs ys = sequence $ zipWith f xs ys --- | If the file specified does not exist or its contents does not match the --- given string, then this writes the string to the file. -writeFileIfDifferent :: FilePath -> String -> IO () -writeFileIfDifferent path newContents = do - exists <- doesFileExist path - -- We need to read the file strictly, otherwise lazy IO might try to write the - -- file while it's still open and locked for reading. - doWrite <- if exists - then (newContents /=) <$> readStrictly - else return True - when doWrite $ writeFile path newContents - where readStrictly = withFile path ReadMode $ \handle -> do - contents <- hGetContents handle - _ <- evaluate $ length contents - return contents - -- | Upper cases the first character of a string, and lower cases the rest of -- it. Does nothing to an empty string. capitalize :: String -> String @@ -96,3 +145,27 @@ upperFirst :: String -> String upperFirst "" = "" upperFirst (c:cs) = toUpper c : cs + +-- | Adds a noun onto a number in either singular or plural form, depending on +-- the number. +pluralize :: Int -> String -> String -> String +pluralize num singular plural = + if num == 1 + then "1 " ++ singular + else show num ++ " " ++ plural + +-- | If the file specified does not exist or its contents does not match the +-- given string, then this writes the string to the file. +writeFileIfDifferent :: FilePath -> String -> IO () +writeFileIfDifferent path newContents = do + exists <- doesFileExist path + -- We need to read the file strictly, otherwise lazy IO might try to write the + -- file while it's still open and locked for reading. + doWrite <- if exists + then (newContents /=) <$> readStrictly + else return True + when doWrite $ writeFile path newContents + where readStrictly = withFile path ReadMode $ \handle -> do + contents <- hGetContents handle + _ <- evaluate $ length contents + return contents diff --git a/src/Foreign/Hoppy/Generator/Common/Consume.hs b/src/Foreign/Hoppy/Generator/Common/Consume.hs --- a/src/Foreign/Hoppy/Generator/Common/Consume.hs +++ b/src/Foreign/Hoppy/Generator/Common/Consume.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, UndecidableInstances #-} -- | A monad for consuming streams. module Foreign.Hoppy.Generator.Common.Consume ( @@ -24,18 +24,24 @@ runConsumeT, evalConsumeT, execConsumeT, + Consume, + runConsume, + evalConsume, + execConsume, ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<*>), Applicative, pure) #endif import Control.Monad (ap, liftM) -import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.State (StateT, get, put, runStateT) +import Control.Monad.Trans (MonadTrans, lift) import Data.Tuple (swap) -- | A typeclass for monads that can consume items from a stream. -class MonadConsume s m | m -> s where +class Monad m => MonadConsume s m | m -> s where -- | Attempts to consume an item from the stream. Returns an item if the -- stream is not empty. next :: m (Maybe s) @@ -64,18 +70,35 @@ [] -> return Nothing x:xs -> put' xs >> return (Just x) +instance MonadConsume s m => MonadConsume s (ExceptT e m) where + next = lift next + +instance MonadConsume s m => MonadConsume s (StateT d m) where + next = lift next + -- | Runs the consume action, returning the remainder of the stream, and the -- action's result. runConsumeT :: Monad m => [s] -> ConsumeT s m a -> m ([s], a) -runConsumeT stream (ConsumeT m) = liftM swap $ runStateT m stream +runConsumeT stream (ConsumeT m) = swap <$> runStateT m stream -- | Runs the consume action, returning the action's result. evalConsumeT :: Monad m => [s] -> ConsumeT s m a -> m a -evalConsumeT stream = liftM snd . runConsumeT stream +evalConsumeT stream = fmap snd . runConsumeT stream -- | Runs the consume action, returning the remainder of the stream. execConsumeT :: Monad m => [s] -> ConsumeT s m a -> m [s] -execConsumeT stream = liftM fst . runConsumeT stream +execConsumeT stream = fmap fst . runConsumeT stream + +type Consume s = ConsumeT s Identity + +runConsume :: [s] -> Consume s a -> ([s], a) +runConsume stream m = runIdentity $ runConsumeT stream m + +evalConsume :: [s] -> Consume s a -> a +evalConsume stream = snd . runConsume stream + +execConsume :: [s] -> Consume s a -> [s] +execConsume stream = fst . runConsume stream get' :: Monad m => ConsumeT s m [s] get' = ConsumeT get diff --git a/src/Foreign/Hoppy/Generator/Compiler.hs b/src/Foreign/Hoppy/Generator/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Compiler.hs @@ -0,0 +1,180 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Data types for compilers and functions for invoking them. +module Foreign.Hoppy.Generator.Compiler ( + -- * Typeclass + Compiler (..), + SomeCompiler (..), + -- * Data types + SimpleCompiler (..), + prependArguments, + appendArguments, + overrideCompilerFromEnvironment, + CustomCompiler (..), + -- * Standard compilers + defaultCompiler, + gppCompiler, + ) where + +import Control.Exception (IOException, try) +import Data.Either (partitionEithers) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import Data.Text (pack, splitOn, unpack) +import Foreign.Hoppy.Generator.Common (filterMaybe, strInterpolate) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.IO (hPutStrLn, stderr) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (createProcess_, proc, showCommandForUser, waitForProcess) + +-- | A compiler that exists on the system for compiling C++ code. +class Show a => Compiler a where + -- | @compileProgram compiler infile outfile@ invokes the given compiler in + -- the input file, to produce the output file. If the compiler fails or can't + -- be called for whatever reason, then an error message is printed to standard + -- error, and false is returned. + compileProgram :: a -> FilePath -> FilePath -> IO Bool + +-- | An existential data type for 'Compiler's. +data SomeCompiler = forall a. Compiler a => SomeCompiler a + +instance Show SomeCompiler where + show (SomeCompiler c) = "" + +instance Compiler SomeCompiler where + compileProgram (SomeCompiler c) = compileProgram c + +-- | A compiler that can compile a source file into a binary with a single +-- program invocation. +-- +-- Within the strings in this data type, including the program path, all +-- occurences of @{in}@ and @{out}@ are expanded to the input and desired output +-- files, respectively. +data SimpleCompiler = SimpleCompiler + { scProgram :: FilePath + -- ^ The name of the compiler program to call. Lookup is subject to the + -- regular search path rules of your operating system. + , scArguments :: [String] + -- ^ Arguments to pass to the compiler. Each string is passed as a separate + -- argument. No further word splitting is done. + } + +instance Show SimpleCompiler where + show compiler = + "" + +instance Compiler SimpleCompiler where + compileProgram compiler inPath outPath = + runProgram compiler + (scProgram compiler) + (scArguments compiler) + (M.fromList [("in", inPath), ("out", outPath)]) + +-- | Adds arguments to the start of a compiler's argument list. +prependArguments :: [String] -> SimpleCompiler -> SimpleCompiler +prependArguments args compiler = + compiler { scArguments = args ++ scArguments compiler } + +-- | Adds arguments to the end of a compiler's argument list. +appendArguments :: [String] -> SimpleCompiler -> SimpleCompiler +appendArguments args compiler = + compiler { scArguments = scArguments compiler ++ args } + +-- | Modifies a 'SimpleCompiler' based on environment variables. +-- +-- If @CXX@ is set and non-empty, it will override the compiler's 'scProgram'. +-- +-- If @CXXFLAGS@ is set and non-empty, it will be split into words and each word +-- will be prepended as an argument to 'scArguments'. Quoting is not supported. +overrideCompilerFromEnvironment :: SimpleCompiler -> IO SimpleCompiler +overrideCompilerFromEnvironment compiler = do + envProgram <- filterMaybe "" <$> lookupEnv "CXX" + envArguments <- filter (/= "") . splitOnSpace . fromMaybe "" <$> lookupEnv "CXXFLAGS" + return compiler + { scProgram = fromMaybe (scProgram compiler) envProgram + , scArguments = envArguments ++ scArguments compiler + } + where splitOnSpace = map unpack . splitOn (pack " ") . pack + +-- | A 'Compiler' that allows plugging arbitary logic into the compilation +-- process. +data CustomCompiler = CustomCompiler + { ccLabel :: String + -- ^ A label to display when the compiler is 'show'n. The string is + -- @\"\\"@. + , ccCompile :: FilePath -> FilePath -> IO Bool + -- ^ Given a source file path and an output path, compiles the source file, + -- producing a binary at the output path. Returns true on success. Logs to + -- standard error and returns false on failure. + } + +instance Show CustomCompiler where + show c = "" + +instance Compiler CustomCompiler where + compileProgram = ccCompile + +-- | The default compiler, used by an 'Foreign.Hoppy.Generator.Spec.Interface' +-- that doesn't specify its own. This is: +-- +-- @'unsafePerformIO' $ 'overrideCompilerFromEnvironment' 'gppCompiler'@ +defaultCompiler :: SimpleCompiler +{-# NOINLINE defaultCompiler #-} +defaultCompiler = unsafePerformIO $ overrideCompilerFromEnvironment gppCompiler + +-- | The GNU C++ compiler, invoked as @g++ -o {out} {in}@. +gppCompiler :: SimpleCompiler +gppCompiler = + SimpleCompiler + { scProgram = "g++" + , scArguments = ["-o", "{out}", "{in}"] + } + +-- | Invokes a program as part of running a compiler. Performs argument +-- interpolation on the program and argument strings. Returns true if the +-- program executes successfully, and false otherwise (logging to stderr). +runProgram :: Show a => a -> FilePath -> [String] -> M.Map String String -> IO Bool +runProgram compiler rawProgram rawArgs values = do + let interpolationResults = + partitionEithers $ + map (strInterpolate values) (rawProgram:rawArgs) + case interpolationResults of + (unknownKey:_, _) -> do + hPutStrLn stderr $ + "Error: Hit unknown binding {" ++ unknownKey ++ "} when executing C++ compiler '" ++ + show compiler ++ ". program = " ++ show rawProgram ++ ", arguments = " ++ + show rawArgs ++ "." + return False + ([], program:args) -> do + let cmdLine = showCommandForUser program args + forkResult <- try $ createProcess_ program $ proc program args + case forkResult of + Left (e :: IOException) -> do + hPutStrLn stderr $ + "Error: Hoppy failed to invoke program (" ++ cmdLine ++ "): " ++ show e + return False + Right (_, _, _, procHandle) -> do + exitCode <- waitForProcess procHandle + case exitCode of + ExitSuccess -> return True + ExitFailure _ -> do + hPutStrLn stderr $ "Error: Hoppy call to program failed (" ++ cmdLine ++ ")." + return False + ([], []) -> error "runProgram: Can't get here." diff --git a/src/Foreign/Hoppy/Generator/Hook.hs b/src/Foreign/Hoppy/Generator/Hook.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Hook.hs @@ -0,0 +1,485 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Hooks for controlling various parts of generators. +module Foreign.Hoppy.Generator.Hook ( + Hooks (..), + defaultHooks, + -- * Enum evaluation + EnumEvaluator, + EnumEvaluatorArgs (..), + EnumEvaluatorResult (..), + evaluateEnumsWithCompiler, + evaluateEnumsWithDefaultCompiler, + makeCppSourceToEvaluateEnums, + interpretOutputToEvaluateEnums, + -- * Internal + 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) +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.Storable (Storable, sizeOf) +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure) +import System.IO (hClose, hPutStrLn, stderr) +import System.Process (readProcessWithExitCode) + +-- | These hooks can be used to customize the behaviour of a Hoppy generator. +data Hooks = Hooks + { hookEvaluateEnums :: EnumEvaluator + -- ^ This hook is invoked once for an interface when the generator needs + -- information about some enums beyond what's been baked into the interface + -- (for example, to compute the enum's numeric type or entry values, see + -- 'EvaluatedEnumData'). This will be called at most once per interface per + -- invocation of the generator. + } + +-- | The default set of hooks associated with an interface. This sets +-- 'hookEvaluateEnums' to 'evaluateEnumsWithDefaultCompiler'. +defaultHooks :: Hooks +defaultHooks = + Hooks + { hookEvaluateEnums = evaluateEnumsWithDefaultCompiler + } + +-- | A function that answers with representation information about an enum (e.g. +-- entries' numeric values) for a given request. On success, it returns the +-- requested data. On failure, it prints a message to standard error and +-- returns @Nothing@. +type EnumEvaluator = EnumEvaluatorArgs -> IO (Maybe EnumEvaluatorResult) + +-- | Inputs to the process of automatically evaluting enums. +data EnumEvaluatorArgs = EnumEvaluatorArgs + { enumEvaluatorArgsInterface :: Interface + -- ^ The interface that enum values are being calculated for. + , enumEvaluatorArgsReqs :: Reqs + -- ^ Requirements (includes, etc.) needed to reference the enum identifiers + -- being evaluated. + , enumEvaluatorArgsSizeofIdentifiers :: [Identifier] + -- ^ The list of identifiers that we need to compute sizeof() for. + , enumEvaluatorArgsEntryIdentifiers :: [Identifier] + -- ^ The list of identifiers to calculate values for. + , enumEvaluatorArgsKeepOutputsOnFailure :: Bool + -- ^ Whether to leave temporary build inputs and outputs on disk in case the + -- calculation fails. If failure does occur and this is true, then the + -- calculation should print to standard error the location of these files + -- (this is taken care of by the @calculateEnumValues*@ functions here.) + } + +-- | Raw outputs parsed from the output of an enum evaluator. +data EnumEvaluatorResult = EnumEvaluatorResult + { enumEvaluatorResultSizes :: ![Int] + -- ^ The sizeof() for each identifier in 'enumEvaluatorArgsSizeofIdentifiers'. + -- The lengths of these two lists must match. + , enumEvaluatorResultValues :: ![Integer] + -- ^ The numeric value for each identifier in 'enumEvaluatorArgsEntryIdentifiers'. + -- The lengths of these two lists must match. + } deriving (Show) + +-- | An 'EnumEvaluatorResult' without any data in it. +emptyEnumEvaluatorResult :: EnumEvaluatorResult +emptyEnumEvaluatorResult = EnumEvaluatorResult + { enumEvaluatorResultSizes = [] + , enumEvaluatorResultValues = [] + } + +-- | Calculates enum values using an interface's compiler. +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 + +-- | Evaluate enums using a specified compiler. +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 + +-- | Constructs the C++ source program to evaluate enums. +makeCppSourceToEvaluateEnums :: EnumEvaluatorArgs -> ByteString +makeCppSourceToEvaluateEnums args = + toLazyByteString $ stringUtf8 $ unlines $ + [ "#include " + , "" + ] ++ [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 (enumEvaluatorArgsEntryIdentifiers args) + (\identifier -> + let rendered = renderIdentifier identifier + in " std::cout << (" ++ rendered ++ ") << ' ' << " ++ + doubleQuote rendered ++ " << '\\n';") ++ + [ "" + , " return 0;" + , "}" + ] + +-- | Interprets the output of a program generated by +-- 'makeCppSourceToEvaluateEnums', returning parsed values if successful, and an +-- error string otherwise. +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 $ enumEvaluatorArgsEntryIdentifiers 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." + +-- | Collects all of the enum values that need calculating in an interface, runs +-- the hook to evaluate them, and stores the result in the interface. This +-- won't recalculate enum data if it's already been calculated. +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 + + -- Collect all exports in the interface. + allExports :: M.Map ExtName Export + allExports = M.unions $ map moduleExports $ M.elems $ interfaceModules iface + + -- Collect pertinent information about all enum exports that we need to + -- evaluate. + -- + -- ExtName: The name of the enum. + -- Maybe Type: The enum's numeric type, if explicitly set. + -- Maybe Identifier: The enum's identifier, if we need to evaluate it. + -- Reqs: Requirements to reference the enum. + -- EnumValueMap: Entries, so that we can evaluate the auto ones. + enumExports :: [(ExtName, Maybe Type, Maybe Identifier, Reqs, EnumValueMap)] + enumExports = flip mapMaybe (M.elems allExports) $ \export -> + flip fmap (getExportEnumInfo export) $ \(info :: EnumInfo) -> + (enumInfoExtName info, + enumInfoNumericType info, + case (enumInfoNumericType info, validateEnumTypes) of + (Just _, False) -> Nothing -- Don't need to evaluate sizeof(). + _ -> Just $ enumInfoIdentifier info, -- Need to evaluate sizeof(). + enumInfoReqs info, + enumInfoValues info) + + -- Determine a list of all values to evaluate, and the Reqs required to do + -- so. + sumReqs :: Reqs + sizeofIdentifiersToEvaluate :: [OrdIdentifier] + entryIdentifiersToEvaluate :: [OrdIdentifier] + (sumReqs, sizeofIdentifiersToEvaluate, entryIdentifiersToEvaluate) = + (\(a, b, c) -> (a, b, S.toList $ S.fromList $ map OrdIdentifier c)) $ + execWriter $ forM_ enumExports $ \(_, _, 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, [], [identifier]) + + -- Evaluate the identifiers we are curious about, using the hook provided by + -- the interface. + evaluatorResult :: EnumEvaluatorResult <- + case (sizeofIdentifiersToEvaluate, entryIdentifiersToEvaluate) of + ([], []) -> return emptyEnumEvaluatorResult + _ -> do + let hooks = interfaceHooks iface + args = EnumEvaluatorArgs + { enumEvaluatorArgsInterface = iface + , enumEvaluatorArgsReqs = sumReqs + , enumEvaluatorArgsSizeofIdentifiers = + map ordIdentifier sizeofIdentifiersToEvaluate + , enumEvaluatorArgsEntryIdentifiers = + map ordIdentifier entryIdentifiersToEvaluate + , enumEvaluatorArgsKeepOutputsOnFailure = keepBuildFailures + } + hookEvaluateEnums hooks args >>= + fromMaybeM + (do hPutStrLn stderr $ + "internalEvaluateEnumsForInterface': Failed to build and run program. Aborting." + exitFailure) + + let 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 + + -- Build a map containing the evaluated type and numeric values for all of + -- the enums in the interface. + evaluatedDataMap :: M.Map ExtName EvaluatedEnumData <- + fmap M.fromList $ forM enumExports $ \(extName, maybeNumericType, maybeIdent, _, values) -> do + -- Build a map containing all of the numeric values in the enum. + 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) + + -- Determine the bounds for those values, and use those to select a + -- numeric type that we should use outside of C++ to represent the enum's + -- values. C++ doesn't give us a way to ask for the numeric type it uses + -- directly, so we manually pick a numeric type of the right size that can + -- handle everything. + bytes <- case (maybeNumericType, maybeIdent) of + (Just numericType, Just identifier) -> do + providedBytes <- numBytes <$> getNumericTypeInfo extName numericType + evaluatedBytes <- getIdentifierSize identifier + + -- Verify that the explicit numeric type set on the enum is correct to + -- use. + 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) + +-- | Bound information about numeric types. +data NumericTypeInfo = NumericTypeInfo + { numType :: Type + , numBytes :: Int + , numMinBound :: Integer + , numMaxBound :: Integer + } + +-- | Numeric types usable to hold enum values. These are ordered by decreasing +-- precedence (increasing word size). +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 + +-- | Selects the preferred numeric type for holding numeric values in the given +-- range. +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 diff --git a/src/Foreign/Hoppy/Generator/Hook.hs-boot b/src/Foreign/Hoppy/Generator/Hook.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Hook.hs-boot @@ -0,0 +1,25 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Hook ( + Hooks, + defaultHooks, + ) where + +data Hooks + +defaultHooks :: Hooks diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp.hs b/src/Foreign/Hoppy/Generator/Language/Cpp.hs --- a/src/Foreign/Hoppy/Generator/Language/Cpp.hs +++ b/src/Foreign/Hoppy/Generator/Language/Cpp.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -19,45 +19,125 @@ -- | Shared portion of the C++ code generator. Usable by binding definitions. module Foreign.Hoppy.Generator.Language.Cpp ( + -- * Code generation monad + Generator, + Env, + execGenerator, + addIncludes, addInclude, addReqsM, + askInterface, askModule, abort, + -- * Names + makeCppName, externalNameToCpp, - classDeleteFnCppName, - classCastFnCppName, - callbackClassName, - callbackImplClassName, - callbackFnName, toArgName, toArgNameAlt, exceptionIdArgName, exceptionPtrArgName, exceptionVarName, exceptionRethrowFnName, + -- * Token rendering Chunk (..), + codeChunk, + includesChunk, runChunkWriter, evalChunkWriter, execChunkWriter, runChunkWriterT, evalChunkWriterT, execChunkWriterT, + -- * High-level code generation + SayExportMode (..), say, says, sayIdentifier, + renderIdentifier, sayVar, sayType, + sayFunction, + -- * Auxiliary functions + typeToCType, + typeReqs, + findExportModule, + getEffectiveExceptionHandlers, ) where -import Control.Monad (liftM) +import Control.Monad (unless) +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.Writer (MonadWriter, Writer, WriterT, runWriter, runWriterT, tell) +import Control.Monad.Trans (lift) import Data.Foldable (forM_) import Data.List (intercalate, intersperse) +import qualified Data.Map as M +import qualified Data.Set as S import Foreign.Hoppy.Generator.Common -import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Spec.Base +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (classIdentifier, classReqs) import Foreign.Hoppy.Generator.Types -cppNameSeparator :: String -cppNameSeparator = "__" +-- | A generator monad for C++ code. +-- +-- TODO This should not simply be a type synonym. +type Generator = ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) +-- | Context information for generating C++ code. +data Env = Env + { envInterface :: Interface + , envModule :: Module + } + +-- | Runs a generator action and returns its output, or an error message if +-- unsuccessful. +execGenerator :: Interface -> Module -> Maybe String -> Generator a -> Either ErrorMsg String +execGenerator iface m maybeHeaderGuardName action = do + chunk <- execChunkWriterT $ runReaderT action $ Env iface m + let contents = chunkContents chunk + includes = chunkIncludes chunk + return $ chunkContents $ execChunkWriter $ do + say "////////// GENERATED FILE, EDITS WILL BE LOST //////////\n" + forM_ maybeHeaderGuardName $ \x -> do + says ["\n#ifndef ", x, "\n"] + says ["#define ", x, "\n"] + unless (S.null includes) $ do + say "\n" + forM_ includes $ say . includeToString + say "\nextern \"C\" {\n" + say contents + say "\n} // extern \"C\"\n" + forM_ maybeHeaderGuardName $ \x -> + says ["\n#endif // ifndef ", x, "\n"] + +-- | Adds @#include@ statements to the includes block generated at the top of +-- the currently generating file. +addIncludes :: MonadWriter [Chunk] m => [Include] -> m () +addIncludes = tell . (:[]) . includesChunk . S.fromList + +-- | Adds an @#include@ statement to the includes block generated at the top of +-- the currently generating file. +addInclude :: MonadWriter [Chunk] m => Include -> m () +addInclude = addIncludes . (:[]) + +-- | Adds requirements ('Reqs' i.e. C++ includes) to the includes block +-- generated at the top of the currently generating file. +-- +-- Have to call this @addReqsM@, 'addReqs' is taken by 'HasReqs'. +addReqsM :: MonadWriter [Chunk] m => Reqs -> m () +addReqsM = tell . (:[]) . includesChunk . reqsIncludes + +-- | Returns the currently generating interface. +askInterface :: MonadReader Env m => m Interface +askInterface = fmap envInterface ask + +-- | Returns the currently generating module. +askModule :: MonadReader Env m => m Module +askModule = fmap envModule ask + +-- | Halts generation and returns the given error message. +abort :: ErrorMsg -> Generator a +abort = lift . lift . Left + +-- | Constructs a C++ identifier by combining a list of strings with @__@. makeCppName :: [String] -> String makeCppName = intercalate cppNameSeparator + where cppNameSeparator = "__" -- | \"genpop\" is the prefix used for individually exported functions. externalNamePrefix :: String @@ -68,42 +148,6 @@ externalNameToCpp extName = makeCppName [externalNamePrefix, fromExtName extName] -makeClassCppName :: String -> Class -> String -makeClassCppName prefix cls = makeCppName [prefix, fromExtName $ classExtName cls] - --- | \"gendel\" is the prefix used for wrappers for @delete@ calls. -classDeleteFnPrefix :: String -classDeleteFnPrefix = "gendel" - --- | Returns the C++ binding function name of the wrapper for the delete method --- for a class. -classDeleteFnCppName :: Class -> String -classDeleteFnCppName = makeClassCppName classDeleteFnPrefix - --- | @classCastFnCppName fromCls toCls@ returns the name of the generated C++ --- function that casts a pointer from @fromCls@ to @toCls@. -classCastFnCppName :: Class -> Class -> String -classCastFnCppName from to = - concat [ "gencast__" - , fromExtName $ classExtName from - , "__" - , fromExtName $ classExtName to - ] - --- | Returns the name of the outer, copyable class for a callback. -callbackClassName :: Callback -> String -callbackClassName = fromExtName . callbackExtName - --- | Returns the name of the internal, non-copyable implementation class for a --- callback. -callbackImplClassName :: Callback -> String -callbackImplClassName = (++ "_impl") . fromExtName . callbackExtName - --- | Returns the name of the C++ binding function that creates a C++ callback --- wrapper object from a function pointer to foreign code. -callbackFnName :: Callback -> String -callbackFnName = externalNameToCpp . callbackExtName - -- | Returns a distinct argument variable name for each nonnegative number. toArgName :: Int -> String toArgName = ("arg" ++) . show @@ -141,15 +185,35 @@ identifierChars :: String identifierChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_" --- | A chunk is a string that contains an arbitrary portion of C++ code. The --- only requirement is that chunk boundaries are also C++ token boundaries, --- because the generator monad automates the process of inserting whitespace --- between chunk boundaries where necessary. -newtype Chunk = Chunk { chunkContents :: String } +-- | A chunk is a string that contains an arbitrary portion of C++ code, +-- together with a set of includes. The only requirement is that chunk's code +-- boundaries are also C++ token boundaries, because the generator monad +-- automates the process of inserting whitespace between chunk boundaries where +-- necessary. +data Chunk = Chunk + { chunkContents :: !String + , chunkIncludes :: !(S.Set Include) + } +-- | Builds a 'Chunk' that contains the given code string. +codeChunk :: String -> Chunk +codeChunk code = + Chunk + { chunkContents = code + , chunkIncludes = S.empty + } + +-- | Builds a 'Chunk' that contains the given includes. +includesChunk :: S.Set Include -> Chunk +includesChunk includes = + Chunk + { chunkContents = "" + , chunkIncludes = includes + } + -- | Runs a 'Chunk' writer, combining them with 'combineChunks' to form a single -- string. -runChunkWriter :: Writer [Chunk] a -> (a, String) +runChunkWriter :: Writer [Chunk] a -> (a, Chunk) runChunkWriter = fmap combineChunks . runWriter -- | Runs a 'Chunk' writer and returns the monad's value. @@ -157,46 +221,64 @@ evalChunkWriter = fst . runChunkWriter -- | Runs a 'Chunk' writer and returns the written log. -execChunkWriter :: Writer [Chunk] a -> String +execChunkWriter :: Writer [Chunk] a -> Chunk execChunkWriter = snd . runChunkWriter -- | Runs a 'Chunk' writer transformer, combining them with 'combineChunks' to -- form a single string. -runChunkWriterT :: Monad m => WriterT [Chunk] m a -> m (a, String) -runChunkWriterT = liftM (fmap combineChunks) . runWriterT +runChunkWriterT :: Monad m => WriterT [Chunk] m a -> m (a, Chunk) +runChunkWriterT = fmap (fmap combineChunks) . runWriterT -- | Runs a 'Chunk' writer transformer and returns the monad's value. evalChunkWriterT :: Monad m => WriterT [Chunk] m a -> m a -evalChunkWriterT = liftM fst . runChunkWriterT +evalChunkWriterT = fmap fst . runChunkWriterT -- | Runs a 'Chunk' writer transformer and returns the written log. -execChunkWriterT :: Monad m => WriterT [Chunk] m a -> m String -execChunkWriterT = liftM snd . runChunkWriterT +execChunkWriterT :: Monad m => WriterT [Chunk] m a -> m Chunk +execChunkWriterT = fmap snd . runChunkWriterT --- | Flattens a list of chunks down into a single string. Inserts spaces +-- | Flattens a list of chunks down into a single chunk. Inserts spaces -- between chunks where the ends of adjacent chunks would otherwise merge into a --- single C++ token. -combineChunks :: [Chunk] -> String +-- single C++ token. Combines include sets into a single include set. +combineChunks :: [Chunk] -> Chunk combineChunks chunks = let strs = map chunkContents chunks - in concat $ for (zip ("":strs) strs) $ \(prev, cur) -> - let needsSpace = - not (null prev) && not (null cur) && - (let a = last prev - b = head cur - in -- "intconstx" should become "int const x" - isIdentifierChar a && isIdentifierChar b || - -- Adjacent template parameter '>'s need spacing in old C++. - a == '>' && b == '>') - in if needsSpace then ' ':cur else cur + in Chunk + { chunkContents = + concat $ for (zip ("":strs) strs) $ \(prev, cur) -> + let needsSpace = + not (null prev) && not (null cur) && + (let a = last prev + b = head cur + in -- "intconstx" should become "int const x" + isIdentifierChar a && isIdentifierChar b || + -- Adjacent template parameter '>'s need spacing in old C++. + a == '>' && b == '>') + in if needsSpace then ' ':cur else cur + , chunkIncludes = S.unions $ map chunkIncludes chunks + } + +-- | The section of code that Hoppy is generating, for an export. +data SayExportMode = + SaySource + -- ^ Hoppy is generating the C++ source file for a module. The generator + -- should emit C++ definitions that will be imported over foreign language's + -- FFIs. This is the main place for code generation in C++ bindings. + | SayHeader + -- ^ Hoppy is generating the C++ header file for a module. The generator + -- should emit C++ declarations that can be @#include@d during the source + -- file generation of other exportable entities, in order to refer to the + -- current entity. If it is not possible for other entities to refer to + -- this one, then nothing needs to be generated. + -- | Emits a single 'Chunk'. say :: MonadWriter [Chunk] m => String -> m () -say = tell . (:[]) . Chunk +say = tell . (:[]) . codeChunk -- | Emits a 'Chunk' for each string in a list. says :: MonadWriter [Chunk] m => [String] -> m () -says = tell . map Chunk +says = tell . map codeChunk -- | Emits an 'Identifier'. sayIdentifier :: MonadWriter [Chunk] m => Identifier -> m () @@ -211,6 +293,10 @@ sequence_ $ intersperse (say ", ") $ map (sayType Nothing) args say ">" +-- | Renders an 'Identifier' to a string. +renderIdentifier :: Identifier -> String +renderIdentifier = chunkContents . execChunkWriter . sayIdentifier + -- | @sayVar name maybeParamNames t@ speaks a variable declaration of the form -- @\ \@, where @\@ is the given name, and @\@ is -- rendered by giving @maybeParamNames@ and @t@ to 'sayType'. @@ -236,49 +322,21 @@ else say "(" >> unwrappedOuter >> say ")" in case t of Internal_TVoid -> say "void" >> outer - Internal_TBool -> say "bool" >> outer - Internal_TChar -> say "char" >> outer - Internal_TUChar -> say "unsigned char" >> outer - Internal_TShort -> say "short" >> outer - Internal_TUShort -> say "unsigned short" >> outer - Internal_TInt -> say "int" >> outer - Internal_TUInt -> say "unsigned int" >> outer - Internal_TLong -> say "long" >> outer - Internal_TULong -> say "unsigned long" >> outer - Internal_TLLong -> say "long long" >> outer - Internal_TULLong -> say "unsigned long long" >> outer - Internal_TFloat -> say "float" >> outer - Internal_TDouble -> say "double" >> outer - Internal_TInt8 -> say "int8_t" >> outer - Internal_TInt16 -> say "int16_t" >> outer - Internal_TInt32 -> say "int32_t" >> outer - Internal_TInt64 -> say "int64_t" >> outer - Internal_TWord8 -> say "uint8_t" >> outer - Internal_TWord16 -> say "uint16_t" >> outer - Internal_TWord32 -> say "uint32_t" >> outer - Internal_TWord64 -> say "uint64_t" >> outer - Internal_TPtrdiff -> say "ptrdiff_t" >> outer - Internal_TSize -> say "size_t" >> outer - Internal_TSSize -> say "ssize_t" >> outer - Internal_TEnum e -> sayIdentifier (enumIdentifier e) >> outer - Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of - Just identifier -> sayIdentifier identifier >> outer - Nothing -> sayType' (bitspaceType b) maybeParamNames outerPrec unwrappedOuter Internal_TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer Internal_TRef t' -> sayType' t' Nothing prec $ say "&" >> outer - Internal_TFn paramTypes retType -> sayType' retType Nothing prec $ do + Internal_TFn params retType -> sayType' retType Nothing prec $ do outer say "(" sequence_ $ intersperse (say ", ") $ - for (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $ - \(ptype, pname) -> - sayType' ptype Nothing topPrecedence $ forM_ pname say + for (zip params $ maybe (repeat Nothing) (map Just) $ maybeParamNames) $ + \(param, pname) -> + sayType' (parameterType param) Nothing topPrecedence $ forM_ pname say say ")" - Internal_TCallback cb -> says [callbackImplClassName cb, "*"] >> outer Internal_TObj cls -> sayIdentifier (classIdentifier cls) >> outer Internal_TObjToHeap cls -> sayType' (refT $ constT $ objT cls) maybeParamNames outerPrec unwrappedOuter Internal_TToGc t' -> sayType' t' maybeParamNames outerPrec unwrappedOuter + Internal_TManual s -> say (conversionSpecCppName $ conversionSpecCpp s) >> outer Internal_TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter -- TODO ^ Is using the outer stuff correctly here? @@ -291,3 +349,79 @@ Internal_TPtr {} -> 9 Internal_TRef {} -> 9 _ -> 8 + +-- | Renders a C++ function. +sayFunction :: + String -- ^ Function name. + -> [String] -- ^ Parameter names. + -> Type -- ^ Function type. This should use 'fnT' or 'fnT''. + -> Maybe (Generator ()) + -- ^ If present, then the function is defined and the action here is used + -- to render its body. If absent, then the function is only declared (no + -- function body). + -> Generator () +sayFunction name paramNames t maybeBody = do + case t of + Internal_TFn {} -> return () + _ -> abort $ concat ["sayFunction: A function type is required, given ", show t, "."] + say "\n" -- New top-level structure, leave a blank line. + sayVar name (Just paramNames) t + case maybeBody of + Nothing -> say ";\n" + Just body -> do + say " {\n" + body -- TODO Indent. + say "}\n" + +-- | Returns a 'Type' iff there is a C type distinct from the given C++ type +-- that should be used for conversion. +-- +-- This returns @Nothing@ for 'Internal_TManual'. TManual needs special +-- handling. +typeToCType :: Type -> Generator (Maybe Type) +typeToCType t = case t of + Internal_TRef t' -> return $ Just $ ptrT t' + Internal_TObj _ -> return $ Just $ ptrT $ constT t + Internal_TObjToHeap cls -> return $ Just $ ptrT $ objT cls + Internal_TToGc t'@(Internal_TObj _) -> return $ Just $ ptrT t' + Internal_TToGc t' -> typeToCType t' + Internal_TConst t' -> typeToCType t' + Internal_TManual s -> conversionSpecCppConversionType $ conversionSpecCpp s + _ -> return Nothing + +-- | Returns the requirements to refer to a type from C++ code. This is a +-- monadic function so that it has access to the environment, but it does not +-- emit any code. +typeReqs :: Type -> Generator Reqs +typeReqs t = case t of + Internal_TVoid -> return mempty + Internal_TPtr t' -> typeReqs t' + Internal_TRef t' -> typeReqs t' + Internal_TFn params retType -> + -- TODO Is the right 'ReqsType' being used recursively here? + mconcat <$> mapM typeReqs (retType : map parameterType params) + Internal_TObj cls -> return $ classReqs cls + Internal_TObjToHeap cls -> return $ classReqs cls + Internal_TToGc t' -> typeReqs t' + Internal_TConst t' -> typeReqs t' + Internal_TManual s -> conversionSpecCppReqs $ conversionSpecCpp s + +-- | Looks up the module exporting the given external name in the current +-- interface. 'abort' is called if the external name is not found. +findExportModule :: ExtName -> Generator Module +findExportModule extName = + fromMaybeM (abort $ concat + ["findExportModule: Can't find module exporting ", fromExtName extName, "."]) =<< + fmap (M.lookup extName . interfaceNamesToModules) askInterface + +-- | Combines the given exception handlers (from a particular exported entity) +-- with the handlers from the current module and interface. The given handlers +-- have highest precedence, followed by module handlers, followed by interface +-- handlers. +getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers +getEffectiveExceptionHandlers handlers = do + ifaceHandlers <- interfaceExceptionHandlers <$> askInterface + moduleHandlers <- getExceptionHandlers <$> askModule + -- Exception handlers declared lower in the hierarchy take precedence over + -- those higher in the hierarchy; ExceptionHandlers is a left-biased monoid. + return $ mconcat [handlers, moduleHandlers, ifaceHandlers] diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp.hs-boot b/src/Foreign/Hoppy/Generator/Language/Cpp.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Cpp.hs-boot @@ -0,0 +1,33 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Language.Cpp ( + Generator, + SayExportMode, + ) where + +import Control.Monad.Reader (ReaderT) +import Control.Monad.Writer (WriterT) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Base (ErrorMsg) + +type Generator = ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) + +data Env + +newtype Chunk = Chunk { chunkContents :: String } + +data SayExportMode diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP, ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | Internal portion of the C++ code generator. module Foreign.Hoppy.Generator.Language.Cpp.Internal ( @@ -27,95 +27,24 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (liftM, unless, when) -import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) -import Control.Monad.Writer (WriterT, execWriterT, runWriterT, tell) +import Control.Monad (when) +import Control.Monad.Writer (execWriterT, tell) import Control.Monad.Trans (lift) import Data.Foldable (forM_) #if !MIN_VERSION_base(4,8,0) import Data.Functor ((<$)) #endif -import Data.List (intersperse) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe, isJust) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mappend, mconcat, mempty) #endif -import qualified Data.Set as S import Foreign.Hoppy.Generator.Common import Foreign.Hoppy.Generator.Language.Cpp import Foreign.Hoppy.Generator.Spec import Foreign.Hoppy.Generator.Types -data CoderDirection = DoDecode | DoEncode - deriving (Eq, Show) - -type Generator = ReaderT Env (WriterT [Chunk] (WriterT (S.Set Include) (Either ErrorMsg))) - -data Env = Env - { envInterface :: Interface - , envModule :: Module - } - -addIncludes :: [Include] -> Generator () -addIncludes = lift . lift . tell . S.fromList - -addInclude :: Include -> Generator () -addInclude = addIncludes . (:[]) - --- Have to call this addReqsM, addReqs is taken by HasReqs. -addReqsM :: Reqs -> Generator () -addReqsM = lift . lift . tell . reqsIncludes - -askInterface :: MonadReader Env m => m Interface -askInterface = liftM envInterface ask - -askModule :: MonadReader Env m => m Module -askModule = liftM envModule ask - --- | Halts generation and returns the given error message. -abort :: ErrorMsg -> Generator a -abort = lift . lift . lift . Left - -execGenerator :: Interface -> Module -> Maybe String -> Generator a -> Either ErrorMsg String -execGenerator interface m maybeHeaderGuardName action = do - (contents, includes) <- - (runWriterT $ - -- WriterT (S.Set Include) (Either String) String: - execChunkWriterT $ - -- WriterT [Chunk] (WriterT (S.Set Include) (Either String)) a: - runReaderT action $ Env interface m) - :: Either String (String, S.Set Include) - return $ execChunkWriter $ do - say "////////// GENERATED FILE, EDITS WILL BE LOST //////////\n" - forM_ maybeHeaderGuardName $ \x -> do - says ["\n#ifndef ", x, "\n"] - says ["#define ", x, "\n"] - unless (S.null includes) $ do - say "\n" - forM_ includes $ say . includeToString - say "\nextern \"C\" {\n" - say contents - say "\n} // extern \"C\"\n" - forM_ maybeHeaderGuardName $ \x -> - says ["\n#endif // ifndef ", x, "\n"] - -sayFunction :: String -> [String] -> Type -> Maybe (Generator ()) -> Generator () -sayFunction name paramNames t maybeBody = do - case t of - Internal_TFn {} -> return () - _ -> abort $ concat ["sayFunction: A function type is required, given ", show t, "."] - say "\n" -- New top-level structure, leave a blank line. - sayVar name (Just paramNames) t - case maybeBody of - Nothing -> say ";\n" - Just body -> do - say " {\n" - body -- TODO Indent. - say "}\n" - -- | The in-memory result of generating C++ code for an interface. -data Generation = Generation +newtype Generation = Generation { generatedFiles :: M.Map FilePath String -- ^ A map from paths of generated files to the contents of those files. -- The file paths are relative paths below the C++ generation root. @@ -123,21 +52,21 @@ -- | Runs the C++ code generator against an interface. generate :: Interface -> Either ErrorMsg Generation -generate interface = +generate iface = fmap (Generation . M.fromList) $ execWriterT $ - forM_ (M.elems $ interfaceModules interface) $ \m -> do - let headerGuard = concat ["HOPPY_MODULE_", interfaceName interface, "_", moduleName m] - header <- lift $ execGenerator interface m (Just headerGuard) sayModuleHeader + forM_ (M.elems $ interfaceModules iface) $ \m -> do + let headerGuard = concat ["HOPPY_MODULE_", interfaceName iface, "_", moduleName m] + header <- lift $ execGenerator iface m (Just headerGuard) sayModuleHeader tell [(moduleHppPath m, header)] - source <- lift $ execGenerator interface m Nothing sayModuleSource + source <- lift $ execGenerator iface m Nothing sayModuleSource tell [(moduleCppPath m, source)] sayModuleHeader :: Generator () sayModuleHeader = do m <- askModule addReqsM $ moduleReqs m - mapM_ (sayExport False) $ M.elems $ moduleExports m + mapM_ (sayExportCpp SayHeader) $ M.elems $ moduleExports m iface <- askInterface when (interfaceExceptionSupportModule iface == Just m) $ @@ -147,608 +76,12 @@ sayModuleSource = do m <- askModule addInclude $ includeLocal $ moduleHppPath m - mapM_ (sayExport True) $ M.elems $ moduleExports m + mapM_ (sayExportCpp SaySource) $ M.elems $ moduleExports m iface <- askInterface when (interfaceExceptionSupportModule iface == Just m) $ sayExceptionSupport True -sayExport :: Bool -> Export -> Generator () -sayExport sayBody export = case export of - ExportVariable v -> when sayBody $ sayExportVariable v - - -- Nothing to do C++ side for an enum or bitspace. - ExportEnum _ -> return () - ExportBitspace _ -> return () - - ExportFn fn -> - -- Export a single function. - when sayBody $ do - addReqsM $ fnReqs fn - sayExportFn (fnExtName fn) - (case fnCName fn of - FnName identifier -> CallFn $ sayIdentifier identifier - FnOp op -> CallOp op) - Nothing - (fnParams fn) - (fnReturn fn) - (fnExceptionHandlers fn) - sayBody - - ExportClass cls -> when sayBody $ do - let clsPtr = ptrT $ objT cls - constClsPtr = ptrT $ constT $ objT cls - -- TODO Is this redundant for a completely empty class? (No ctors or methods, private dtor.) - addReqsM $ classReqs cls -- This is needed at least for the delete function. - - -- Export each of the class's constructors. - forM_ (classCtors cls) $ \ctor -> - sayExportFn (classEntityExtName cls ctor) - (CallFn $ say "new" >> sayIdentifier (classIdentifier cls)) - Nothing - (ctorParams ctor) - clsPtr - (ctorExceptionHandlers ctor) - sayBody - - -- Export a delete function for the class. - when (classDtorIsPublic cls) $ - sayFunction (classDeleteFnCppName cls) - ["self"] - (fnT [constClsPtr] voidT) $ - Just $ say "delete self;\n" - - -- Export each of the class's variables. - forM_ (classVariables cls) $ sayExportClassVariable cls - - -- Export each of the class's methods. - forM_ (classMethods cls) $ \method -> do - let static = case methodStatic method of - Static -> True - Nonstatic -> False - thisType = case methodConst method of - Const -> constClsPtr - Nonconst -> clsPtr - nonMemberCall = static || case methodImpl method of - RealMethod {} -> False - FnMethod {} -> True - sayExportFn (classEntityExtName cls method) - (case methodImpl method of - RealMethod name -> case name of - FnName cName -> CallFn $ do - when static $ do - sayIdentifier (classIdentifier cls) - say "::" - say cName - FnOp op -> CallOp op - FnMethod name -> case name of - FnName cName -> CallFn $ sayIdentifier cName - FnOp op -> CallOp op) - (if nonMemberCall then Nothing else Just thisType) - (methodParams method) - (methodReturn method) - (methodExceptionHandlers method) - sayBody - - -- Export upcast functions for the class to its direct superclasses. - forM_ (classSuperclasses cls) $ genUpcastFns cls - -- Export downcast functions from the class's direct and indirect - -- superclasses to it. - unless (classIsSubclassOfMonomorphic cls) $ - forM_ (classSuperclasses cls) $ genDowncastFns cls - - ExportCallback cb -> sayExportCallback sayBody cb - - where genUpcastFns :: Class -> Class -> Generator () - genUpcastFns cls ancestorCls = do - sayFunction (classCastFnCppName cls ancestorCls) - ["self"] - (fnT [ptrT $ constT $ objT cls] $ ptrT $ constT $ objT ancestorCls) - (Just $ say "return self;\n") - forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls - - genDowncastFns :: Class -> Class -> Generator () - genDowncastFns cls ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do - let clsPtr = ptrT $ constT $ objT cls - ancestorPtr = ptrT $ constT $ objT ancestorCls - sayFunction (classCastFnCppName ancestorCls cls) - ["self"] - (fnT [ancestorPtr] clsPtr) $ Just $ do - say "return dynamic_cast<" - sayType Nothing clsPtr - say ">(self);\n" - forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls - -sayExportVariable :: Variable -> Generator () -sayExportVariable v = - sayExportVariable' (varType v) - Nothing - True - (varGetterExtName v) - (varSetterExtName v) - (sayIdentifier $ varIdentifier v) - -sayExportClassVariable :: Class -> ClassVariable -> Generator () -sayExportClassVariable cls v = - sayExportVariable' (classVarType v) - (case classVarStatic v of - Nonstatic -> Just (ptrT $ constT $ objT cls, ptrT $ objT cls) - Static -> Nothing) - (classVarGettable v) - (classVarGetterExtName cls v) - (classVarSetterExtName cls v) - (case classVarStatic v of - Nonstatic -> say $ classVarCName v - Static -> do sayIdentifier $ classIdentifier cls - says ["::", classVarCName v]) - -sayExportVariable' :: Type - -> Maybe (Type, Type) - -> Bool - -> ExtName - -> ExtName - -> Generator () - -> Generator () -sayExportVariable' t maybeThisTypes gettable getterName setterName sayVarName = do - let (isConst, deconstType) = case t of - Internal_TConst t -> (True, t) - t -> (False, t) - - -- Say a getter function. - when gettable $ - sayExportFn getterName - (VarRead sayVarName) - (fmap fst maybeThisTypes) - [] - deconstType - mempty - True - - -- Say a setter function. - unless isConst $ - sayExportFn setterName - (VarWrite sayVarName) - (fmap snd maybeThisTypes) - [deconstType] - voidT - mempty - True - -data CallType = - CallOp Operator - | CallFn (Generator ()) - | VarRead (Generator ()) - | VarWrite (Generator ()) - -sayExportFn :: ExtName - -> CallType - -> Maybe Type - -> [Type] - -> Type - -> ExceptionHandlers - -> Bool - -> Generator () -sayExportFn extName callType maybeThisType paramTypes retType exceptionHandlers sayBody = do - handlerList <- exceptionHandlersList <$> getEffectiveExceptionHandlers exceptionHandlers - let catches = not $ null handlerList - addExceptionParamNames = - if catches then (++ [exceptionIdArgName, exceptionPtrArgName]) else id - addExceptionParamTypes = if catches then (++ [ptrT intT, ptrT $ ptrT voidT]) else id - - paramCount = length paramTypes - paramCTypeMaybes = map typeToCType paramTypes - paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes - retCTypeMaybe = typeToCType retType - retCType = fromMaybe retType retCTypeMaybe - - addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes) - - sayFunction (externalNameToCpp extName) - (maybe id (const ("self":)) maybeThisType $ - addExceptionParamNames $ - zipWith3 (\t ctm -> case t of - Internal_TCallback {} -> toArgNameAlt - _ -> if isJust ctm then toArgNameAlt else toArgName) - paramTypes paramCTypeMaybes [1..paramCount]) - (fnT (addExceptionParamTypes $ maybe id (:) maybeThisType paramCTypes) - retCType) $ - if not sayBody - then Nothing - else Just $ do - when catches $ do - say "try {\n" - says ["*", exceptionIdArgName, " = 0;\n"] - - -- Convert arguments that aren't passed in directly. - mapM_ (sayArgRead DoDecode) $ zip3 [1..] paramTypes paramCTypeMaybes - - let -- Determines how to call the exported function or method. - sayCall = case callType of - CallOp op -> do - say "(" - let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0 - paramNames@(p1:p2:_) = (if isJust maybeThisType then ("(*self)":) else id) $ - map toArgName [1..] - assertParamCount n = - when (effectiveParamCount /= n) $ abort $ concat - ["sayExportFn: Operator ", show op, " for export ", show extName, - " requires ", show n, " parameter(s), but has ", show effectiveParamCount, - "."] - case operatorType op of - UnaryPrefixOperator symbol -> assertParamCount 1 >> says [symbol, p1] - UnaryPostfixOperator symbol -> assertParamCount 1 >> says [p1, symbol] - BinaryOperator symbol -> assertParamCount 2 >> says [p1, symbol, p2] - CallOperator -> - says $ p1 : "(" : take (effectiveParamCount - 1) (drop 1 paramNames) ++ [")"] - ArrayOperator -> assertParamCount 2 >> says [p1, "[", p2, "]"] - say ")" - CallFn sayCppName -> do - when (isJust maybeThisType) $ say "self->" - sayCppName - say "(" - sayArgNames paramCount - say ")" - VarRead sayVarName -> do - when (isJust maybeThisType) $ say "self->" - sayVarName - VarWrite sayVarName -> do - when (isJust maybeThisType) $ say "self->" - sayVarName - says [" = ", toArgName 1] - - -- Writes the call, transforming the return value if necessary. - -- These translations should be kept in sync with typeToCType. - sayCallAndReturn retType' retCTypeMaybe' = case (retType', retCTypeMaybe') of - (Internal_TVoid, Nothing) -> sayCall >> say ";\n" - (_, Nothing) -> say "return " >> sayCall >> say ";\n" - (Internal_TBitspace b, Just _) -> do - addReqsM $ bitspaceReqs b - let convFn = bitspaceFromCppValueFn b - say "return " - forM_ convFn $ \f -> says [f, "("] - sayCall - when (isJust convFn) $ say ")" - say ";\n"; - (Internal_TRef cls, Just (Internal_TPtr cls')) | cls == cls' -> - say "return &(" >> sayCall >> say ");\n" - (Internal_TObj cls, - Just (Internal_TPtr (Internal_TConst (Internal_TObj cls')))) | cls == cls' -> - sayReturnNew cls sayCall - (Internal_TObjToHeap cls, Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> - sayReturnNew cls sayCall - (Internal_TToGc (Internal_TObj cls), - Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> - sayReturnNew cls sayCall - (Internal_TToGc retType'', _) -> sayCallAndReturn retType'' retCTypeMaybe' - ts -> abort $ concat ["sayExportFn: Unexpected return types ", show ts, - "while generating binding for ", show extName, "."] - - sayCallAndReturn retType retCTypeMaybe - - when catches $ do - iface <- askInterface - - forM_ handlerList $ \handler -> do - say "} catch (" - case handler of - CatchClass cls -> sayVar exceptionVarName Nothing $ refT $ constT $ objT cls - CatchAll -> say "..." - say ") {\n" - - exceptionId <- case handler of - CatchClass cls -> case interfaceExceptionClassId iface cls of - Just exceptionId -> return exceptionId - Nothing -> abort $ concat - ["sayExportFn: Trying to catch non-exception class ", show cls, - " while generating binding for ", show extName, "."] - CatchAll -> return exceptionCatchAllId - says ["*", exceptionIdArgName, " = ", show $ getExceptionId exceptionId, ";\n"] - - case handler of - CatchAll -> says ["*", exceptionPtrArgName, " = 0;\n"] - CatchClass cls -> do - -- Object pointers don't convert automatically to void*. - says ["*", exceptionPtrArgName, " = reinterpret_cast(new "] - sayType Nothing $ objT cls - says ["(", exceptionVarName, "));\n"] - - -- For all of the types our gateway functions actually return, "return - -- 0" is a valid statement. - when (retType /= Internal_TVoid) $ say "return 0;\n" - - say "}\n" - - where sayReturnNew cls sayCall = - say "return new" >> sayIdentifier (classIdentifier cls) >> say "(" >> - sayCall >> say ");\n" - --- | If @dir@ is 'DoDecode', then we are a C++ function reading an argument from --- foreign code. If @dir@ is 'DoEncode', then we are invoking a foreign --- callback. -sayArgRead :: CoderDirection -> (Int, Type, Maybe Type) -> Generator () -sayArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of - Internal_TBitspace b -> case maybeCType of - Just cType -> do - let cppTypeId = fromMaybe (error $ concat - ["sayArgRead: Expected ", show b, - " to have a C++ type, but it doesn't."]) $ - bitspaceCppTypeIdentifier b - addReqsM $ bitspaceReqs b - case dir of - -- Convert from cType to cppType. - DoDecode -> do - sayIdentifier cppTypeId - says [" ", toArgName n, " = ", fromMaybe "" $ bitspaceToCppValueFn b, - "(", toArgNameAlt n, ");\n"] - -- Convert from cppType to cType. - DoEncode -> do - sayVar (toArgName n) Nothing cType - says [" = ", fromMaybe "" $ bitspaceFromCppValueFn b, - "(", toArgNameAlt n, ");\n"] - Nothing -> - return () - - Internal_TCallback cb -> do - case dir of - DoDecode -> return () - DoEncode -> abort $ concat - ["sayArgRead: Encoding of callbacks is not supported. Given ", - show cb, "."] - says [callbackClassName cb, " ", toArgName n, "(", toArgNameAlt n, ");\n"] - - t@(Internal_TPtr (Internal_TFn paramTypes retType)) -> do - -- Assert that all types referred to in a function pointer type are all - -- representable as C types. - let check label t' = (label ++ " " ++ show t') <$ typeToCType t' - mismatches = catMaybes $ - check "return type" retType : - map (\paramType -> check "parameter" paramType) - paramTypes - unless (null mismatches) $ - abort $ concat $ - "sayArgRead: Some types within a function pointer type use non-C types, " : - "but only C types may be used. The unsupported types are: " : - intersperse "; " mismatches ++ [". The whole function type is ", show t, "."] - - convertDefault - - Internal_TRef t -> convertObj t - - Internal_TObj _ -> convertObj $ constT cppType - - Internal_TObjToHeap cls -> case dir of - DoDecode -> error $ objToHeapTWrongDirectionErrorMsg (Just "sayArgRead") cls - DoEncode -> do - sayIdentifier $ classIdentifier cls - says ["* ", toArgName n, " = new "] - sayIdentifier $ classIdentifier cls - says ["(", toArgNameAlt n, ");\n"] - - Internal_TToGc t' -> case dir of - DoDecode -> error $ toGcTWrongDirectionErrorMsg (Just "sayArgRead") t' - DoEncode -> do - let newCppType = case t' of - -- In the case of (TToGc (TObj _)), we copy the temporary object to - -- the heap and let the foreign language manage that value. - Internal_TObj cls -> objToHeapT cls - _ -> t' - sayArgRead dir (n, newCppType, typeToCType newCppType) - - _ -> convertDefault - - where -- Primitive types don't need to be encoded/decoded. But if maybeCType is a - -- Just, then we're expected to do some encoding/decoding, so something is - -- wrong. - -- - -- TODO Do we need to handle TConst? - convertDefault = forM_ maybeCType $ \cType -> - abort $ concat - ["sayArgRead: Don't know how to ", show dir, " between C-type ", show cType, - " and C++-type ", show cppType, "."] - - convertObj cppType' = case dir of - DoDecode -> do - sayVar (toArgName n) Nothing $ refT cppType' - says [" = *", toArgNameAlt n, ";\n"] - DoEncode -> do - sayVar (toArgName n) Nothing $ ptrT cppType' - says [" = &", toArgNameAlt n, ";\n"] - -sayArgNames :: Int -> Generator () -sayArgNames count = - says $ intersperse ", " $ map toArgName [1..count] - -sayExportCallback :: Bool -> Callback -> Generator () -sayExportCallback sayBody cb = do - throws <- getEffectiveCallbackThrows cb - - let className = callbackClassName cb - implClassName = callbackImplClassName cb - fnName = callbackFnName cb - paramTypes = callbackParams cb - paramCount = length paramTypes - retType = callbackReturn cb - cbType = callbackT cb - fnType = fnT paramTypes retType - - -- The function pointer we receive from foreign code will work with C-types, - -- so determine what that function looks like. - let paramCTypes = zipWith fromMaybe paramTypes $ map typeToCType paramTypes - retCType = fromMaybe retType $ typeToCType retType - - -- Add requirements specified manually by the callback, and for its parameter - -- and return types. - addReqsM . mconcat . (callbackReqs cb:) =<< mapM typeReqs (retType:paramTypes) - - let fnCType = fnT ((if throws then (++ [ptrT intT, ptrT $ ptrT voidT]) else id) - paramCTypes) - retCType - fnPtrCType = ptrT fnCType - - if not sayBody - then do - -- Render the class declarations into the header file. - (sharedPtrReqs, sharedPtrStr) <- interfaceSharedPtr <$> askInterface - addReqsM sharedPtrReqs - - says ["\nclass ", implClassName, " {\n"] - say "public:\n" - says [" explicit ", implClassName, "("] >> sayType Nothing fnPtrCType >> - say ", void(*)(void(*)()), bool);\n" - says [" ~", implClassName, "();\n"] - say " " >> sayVar "operator()" Nothing fnType >> say ";\n" - say "private:\n" - says [" ", implClassName, "(const ", implClassName, "&);\n"] - says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"] - say "\n" - say " " >> sayVar "f_" Nothing (constT fnPtrCType) >> say ";\n" - say " void (*const release_)(void(*)());\n" - say " const bool releaseRelease_;\n" - say "};\n" - - says ["\nclass ", className, " {\n"] - say "public:\n" - says [" ", className, "() {}\n"] - says [" explicit ", className, "(", implClassName, "* impl) : impl_(impl) {}\n"] - say " " >> sayVar "operator()" Nothing fnType >> say ";\n" - say " operator bool() const;\n" - say "private:\n" - says [" ", sharedPtrStr, "<", implClassName, "> impl_;\n"] - say "};\n" - - else do - -- Render the classes' methods into the source file. First render the - -- impl class's constructor. - says ["\n", implClassName, "::", implClassName, "("] >> sayVar "f" Nothing fnPtrCType >> - say ", void (*release)(void(*)()), bool releaseRelease) :\n" - say " f_(f), release_(release), releaseRelease_(releaseRelease) {}\n" - - -- Then render the destructor. - says ["\n", implClassName, "::~", implClassName, "() {\n"] - say " if (release_) {\n" - say " release_(reinterpret_cast(f_));\n" - say " if (releaseRelease_) {\n" - say " release_(reinterpret_cast(release_));\n" - say " }\n" - say " }\n" - say "}\n" - - -- Render the impl operator() method, which does argument decoding and - -- return value encoding and passes C++ values to underlying function - -- poiner. - -- - -- TODO Abstract the duplicated code here and in sayExportFn. - let paramCTypeMaybes = map typeToCType paramTypes - retCTypeMaybe = typeToCType retType - - sayFunction (implClassName ++ "::operator()") - (zipWith (\ctm -> if isJust ctm then toArgNameAlt else toArgName) - paramCTypeMaybes [1..paramCount]) - fnType $ Just $ do - -- Convert arguments that aren't passed in directly. - mapM_ (sayArgRead DoEncode) $ zip3 [1..] paramTypes paramCTypeMaybes - - when throws $ do - says ["int ", exceptionIdArgName, " = 0;\n"] - says ["void *", exceptionPtrArgName, " = 0;\n"] - - -- Add an include for the exception support module to be able to call the - -- C++ rethrow function. - iface <- askInterface - currentModule <- askModule - case interfaceExceptionSupportModule iface of - Just exceptionSupportModule -> - when (exceptionSupportModule /= currentModule) $ - -- TODO Should this be includeStd? - addReqsM $ reqInclude $ includeLocal $ moduleHppPath exceptionSupportModule - Nothing -> abort $ "sayExportCallback: " ++ show iface ++ - " uses exceptions, so it needs an exception support " ++ - "module. Please use interfaceSetExceptionSupportModule." - - -- Invoke the function pointer into foreign code. - let -- | Generates the call to the foreign language function pointer. - sayCall :: Generator () - sayCall = do - say "f_(" - sayArgNames paramCount - when throws $ do - when (paramCount /= 0) $ say ", " - says ["&", exceptionIdArgName, ", &", exceptionPtrArgName] - say ")" - - -- | Generates code to check whether an exception was thrown by the - -- callback, and rethrows it in C++ if so. - sayExceptionCheck :: Generator () - sayExceptionCheck = when throws $ do - says ["if (", exceptionIdArgName, " != 0) { ", - exceptionRethrowFnName, "(", exceptionIdArgName, ", ", - exceptionPtrArgName, "); }\n"] - - case (retType, retCTypeMaybe) of - (Internal_TVoid, Nothing) -> do - sayCall >> say ";\n" - sayExceptionCheck - (_, Nothing) -> do - sayVar "result" Nothing retType >> say " = " >> sayCall >> say ";\n" - sayExceptionCheck - say "return result;\n" - (Internal_TBitspace b, Just _) -> do - addReqsM $ bitspaceReqs b - let convFn = bitspaceToCppValueFn b - sayVar "result" Nothing retType - say " = " - forM_ convFn $ \f -> says [f, "("] - sayCall - when (isJust convFn) $ say ")" - say ";\n"; - sayExceptionCheck - say "return result;\n" - (Internal_TObj cls1, Just retCType@(Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) - | cls1 == cls2 -> do - sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" - sayExceptionCheck - sayVar "result" Nothing retType >> say " = *resultPtr;\n" - say "delete resultPtr;\n" - say "return result;\n" - (Internal_TRef (Internal_TConst (Internal_TObj cls1)), - Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do - sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" - sayExceptionCheck - say "return *resultPtr;\n" - (Internal_TRef (Internal_TObj cls1), - Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do - sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" - sayExceptionCheck - say "return *resultPtr;\n" - ts -> abort $ concat - ["sayExportCallback: Unexpected return types ", show ts, "."] - - -- Render the non-impl operator() method, which simply passes C++ values - -- along to the impl object. - sayFunction (className ++ "::operator()") - (map toArgName [1..paramCount]) - fnType $ Just $ do - case retType of - Internal_TVoid -> say "(*impl_)(" - _ -> say "return (*impl_)(" - sayArgNames paramCount - say ");\n" - - -- Render "operator bool", which detects whether the callback was not - -- default-constructed with no actual impl object. - says [className, "::operator bool() const {\n"] - say "return static_cast(impl_);\n" - say "}\n" - - -- Render the function that creates a new callback object. - let newCallbackFnType = fnT [ fnPtrCType - , ptrT (fnT [ptrT $ fnT [] voidT] voidT) - , boolT - ] - cbType - sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $ - says ["return new ", implClassName, "(f, release, releaseRelease);\n"] - -- | Outputs interface-wide code needed to support exceptions. Currently, this -- comprises the function for rethrowing in C++ an exception transferred from -- a foreign language. @@ -781,113 +114,3 @@ say "}\n" says ["throw \"Internal Hoppy error, ", exceptionRethrowFnName, " got an unknown exception ID.\";\n"] - --- | Returns a 'Type' iff there is a C type distinct from the given C++ type --- that should be used for conversion. -typeToCType :: Type -> Maybe Type -typeToCType t = case t of - -- Because we don't know (although we could...) the direction in which we're - -- converting the bitspace value, when the bitspace has a C++ type we have to - -- assume that it needs to be converted. The caller will sort out whether a - -- conversion is actually requested. - Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of - Just _ -> Just $ bitspaceType b - Nothing -> Nothing - Internal_TRef t' -> Just $ ptrT t' - Internal_TObj _ -> Just $ ptrT $ constT t - Internal_TObjToHeap cls -> Just $ ptrT $ objT cls - Internal_TToGc t'@(Internal_TObj _) -> Just $ ptrT t' - Internal_TToGc t' -> typeToCType t' - Internal_TConst t' -> typeToCType t' - _ -> Nothing - -typeReqs :: Type -> Generator Reqs -typeReqs t = case t of - Internal_TVoid -> return mempty - Internal_TBool -> return mempty - Internal_TChar -> return mempty - Internal_TUChar -> return mempty - Internal_TShort -> return mempty - Internal_TUShort -> return mempty - Internal_TInt -> return mempty - Internal_TUInt -> return mempty - Internal_TLong -> return mempty - Internal_TULong -> return mempty - Internal_TLLong -> return mempty - Internal_TULLong -> return mempty - Internal_TFloat -> return mempty - Internal_TDouble -> return mempty - Internal_TInt8 -> return cstdintReqs - Internal_TInt16 -> return cstdintReqs - Internal_TInt32 -> return cstdintReqs - Internal_TInt64 -> return cstdintReqs - Internal_TWord8 -> return cstdintReqs - Internal_TWord16 -> return cstdintReqs - Internal_TWord32 -> return cstdintReqs - Internal_TWord64 -> return cstdintReqs - Internal_TPtrdiff -> return cstddefReqs - Internal_TSize -> return cstddefReqs - Internal_TSSize -> return cstddefReqs - Internal_TEnum e -> return $ enumReqs e - Internal_TBitspace b -> typeReqs $ bitspaceType b - Internal_TPtr t' -> typeReqs t' - Internal_TRef t' -> typeReqs t' - Internal_TFn paramTypes retType -> - -- TODO Is the right 'ReqsType' being used recursively here? - mconcat <$> mapM typeReqs (retType:paramTypes) - Internal_TCallback cb -> do - -- TODO Should this be includeStd? - cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$> - findExportModule (callbackExtName cb) - -- TODO Is the right 'ReqsType' being used recursively here? - fnTypeReqs <- typeReqs =<< callbackToTFn cb - return $ cbClassReqs `mappend` fnTypeReqs - Internal_TObj cls -> return $ classReqs cls - Internal_TObjToHeap cls -> return $ classReqs cls - Internal_TToGc t' -> typeReqs t' - Internal_TConst t' -> typeReqs t' - -cstddefReqs :: Reqs -cstddefReqs = reqInclude $ includeStd "cstddef" - -cstdintReqs :: Reqs -cstdintReqs = reqInclude $ includeStd "cstdint" - -findExportModule :: ExtName -> Generator Module -findExportModule extName = - fromMaybeM (abort $ concat - ["findExportModule: Can't find module exporting ", fromExtName extName, "."]) =<< - fmap (M.lookup extName . interfaceNamesToModules) askInterface - -getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers -getEffectiveExceptionHandlers handlers = do - ifaceHandlers <- interfaceExceptionHandlers <$> askInterface - moduleHandlers <- getExceptionHandlers <$> askModule - -- Exception handlers declared lower in the hierarchy take precedence over - -- those higher in the hierarchy; ExceptionHandlers is a left-biased monoid. - return $ mconcat [handlers, moduleHandlers, ifaceHandlers] - -getEffectiveCallbackThrows :: Callback -> Generator Bool -getEffectiveCallbackThrows cb = case callbackThrows cb of - Just b -> return b - Nothing -> moduleCallbacksThrow <$> askModule >>= \case - Just b -> return b - Nothing -> interfaceCallbacksThrow <$> askInterface - --- | Constructs the function type for a callback. A callback that throws has --- additional parameters. --- --- Keep this in sync with the Haskell generator's version. -callbackToTFn :: Callback -> Generator Type -callbackToTFn cb = do - throws <- mayThrow - return $ Internal_TFn ((if throws then addExcParams else id) $ callbackParams cb) - (callbackReturn cb) - - where mayThrow = case callbackThrows cb of - Just t -> return t - Nothing -> moduleCallbacksThrow <$> askModule >>= \mt -> case mt of - Just t -> return t - Nothing -> interfaceCallbacksThrow <$> askInterface - - addExcParams = (++ [ptrT intT, ptrT $ ptrT voidT]) diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell.hs b/src/Foreign/Hoppy/Generator/Language/Haskell.hs --- a/src/Foreign/Hoppy/Generator/Language/Haskell.hs +++ b/src/Foreign/Hoppy/Generator/Language/Haskell.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -31,6 +31,7 @@ evalGenerator, execGenerator, renderPartial, + Env (..), askInterface, askModule, askModuleName, @@ -47,65 +48,24 @@ -- * Language extensions addExtension, -- * Code generation + SayExportMode (..), sayLn, saysLn, ln, indent, indentSpaces, sayLet, - toHsEnumTypeName, - toHsEnumTypeName', - toHsEnumCtorName, - toHsEnumCtorName', - toHsBitspaceTypeName, - toHsBitspaceTypeName', - toHsBitspaceValueName, - toHsBitspaceValueName', - toHsBitspaceToNumName, - toHsBitspaceToNumName', - toHsBitspaceClassName, - toHsBitspaceClassName', - toHsBitspaceFromValueName, - toHsBitspaceFromValueName', - toHsValueClassName, - toHsValueClassName', - toHsWithValuePtrName, - toHsWithValuePtrName', - toHsPtrClassName, - toHsPtrClassName', - toHsCastMethodName, - toHsCastMethodName', - toHsDownCastClassName, - toHsDownCastClassName', - toHsDownCastMethodName, - toHsDownCastMethodName', - toHsCastPrimitiveName, - toHsCastPrimitiveName', - toHsConstCastFnName, - toHsConstCastFnName', - toHsDataTypeName, - toHsDataTypeName', - toHsDataCtorName, - toHsDataCtorName', - toHsClassDeleteFnName', - toHsClassDeleteFnPtrName', - toHsCtorName, - toHsCtorName', - toHsMethodName, - toHsMethodName', - toHsClassEntityName, - toHsClassEntityName', - toHsCallbackCtorName, - toHsCallbackCtorName', - toHsCallbackNewFunPtrFnName, - toHsCallbackNewFunPtrFnName', + getExtNameModule, + addExtNameModule, + toHsTypeName, + toHsTypeName', toHsFnName, toHsFnName', toArgName, HsTypeSide (..), cppTypeToHsTypeAndUse, getClassHaskellConversion, - callbackToTFn, + getEffectiveExceptionHandlers, prettyPrint, ) where @@ -113,17 +73,12 @@ import Control.Applicative ((<$>)) #endif import Control.Arrow (first) -#if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except (Except, catchError, runExcept, throwError) -#else -import Control.Monad.Error (catchError, throwError) -#endif -import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Reader (ReaderT, asks, runReaderT) import Control.Monad.Writer (WriterT, censor, runWriterT, tell) import Data.Char (toUpper) import Data.Foldable (forM_) import Data.Function (on) -import Data.Functor (($>)) import Data.List (intercalate, intersperse) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) @@ -135,7 +90,15 @@ import Data.Tuple (swap) import Foreign.Hoppy.Generator.Common import Foreign.Hoppy.Generator.Spec.Base -import Foreign.Hoppy.Generator.Types +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class ( + Class, + ClassHaskellConversion, + classConversion, + classExtName, + classHaskellConversion, + classHaskellConversionType, + ) +import Foreign.Hoppy.Generator.Types (constT, objT, ptrT) import qualified Language.Haskell.Pretty as P import Language.Haskell.Syntax ( HsName (HsIdent), @@ -157,9 +120,9 @@ -- taking into account the 'interfaceHaskellModuleBase' and the -- 'moduleHaskellName'. getModuleName :: Interface -> Module -> String -getModuleName interface m = +getModuleName iface m = intercalate "." $ - interfaceHaskellModuleBase interface ++ + interfaceHaskellModuleBase iface ++ fromMaybe [toModuleName $ moduleName m] (moduleHaskellName m) -- | Performs case conversions on the given string to ensure that it is a valid @@ -174,7 +137,7 @@ where -- | Renders an import as a string that contains one or more lines. renderModuleImport :: (HsImportKey, HsImportSpecs) -> String renderModuleImport (key, specs) = - let moduleName = hsImportModule key + let modName = hsImportModule key maybeQualifiedName = hsImportQualifiedName key isQual = isJust maybeQualifiedName importPrefix = if hsImportSource specs @@ -186,9 +149,9 @@ else "import qualified " in case getHsImportSpecs specs of Nothing -> case maybeQualifiedName of - Nothing -> importPrefix ++ moduleName + Nothing -> importPrefix ++ modName Just qualifiedName -> - concat [importQualifiedPrefix, moduleName, " as ", qualifiedName] + concat [importQualifiedPrefix, modName, " as ", qualifiedName] Just specMap -> let specWords :: [String] specWords = concatWithCommas $ map renderSpecAsWords $ M.assocs specMap @@ -196,14 +159,14 @@ singleLineImport = concat $ (if isQual then importQualifiedPrefix else importPrefix) : - moduleName : " (" : intersperse " " specWords ++ + modName : " (" : intersperse " " specWords ++ case maybeQualifiedName of Nothing -> [")"] Just qualifiedName -> [") as ", qualifiedName] in if null $ drop maxLineLength singleLineImport then singleLineImport else intercalate "\n" $ - (importPrefix ++ moduleName ++ " (") : + (importPrefix ++ modName ++ " (") : groupWordsIntoLines specWords ++ case maybeQualifiedName of Nothing -> [" )"] @@ -221,9 +184,9 @@ HsImportValSome parts -> case parts of [] -> [name ++ " ()"] [part] -> [concat [name, " (", part, ")"]] - part0:parts -> let (parts', [partN]) = splitAt (length parts - 1) parts + part0:parts' -> let (parts'', [partN]) = splitAt (length parts' - 1) parts' in concat [name, " (", part0, ","] : - map (++ ",") parts' ++ + map (++ ",") parts'' ++ [partN ++ ")"] HsImportValAll -> [name ++ " (..)"] @@ -246,17 +209,17 @@ -- flowed. groupWordsIntoLines :: [String] -> [String] groupWordsIntoLines [] = [] - groupWordsIntoLines words = + groupWordsIntoLines wordList = let (wordCount, line, _) = last $ - takeWhile (\(wordCount, _, len) -> wordCount <= 1 || len <= maxLineLength) $ - scanl (\(wordCount, acc, len) word -> - (wordCount + 1, + takeWhile (\(wordCount', _, len) -> wordCount' <= 1 || len <= maxLineLength) $ + scanl (\(wordCount', acc, len) word -> + (wordCount' + 1, concat [acc, " ", word], len + 1 + length word)) (0, "", 0) - words - in line : groupWordsIntoLines (drop wordCount words) + wordList + in line : groupWordsIntoLines (drop wordCount wordList) maxLineLength :: Int maxLineLength = 100 @@ -274,11 +237,7 @@ -- not end with punctuation. If there is a suggestion, include it in -- parentheses at the end of the message. 'withErrorContext' and 'inFunction' -- add context information, and should be given clauses, without punctuation. -#if MIN_VERSION_mtl(2,2,1) type Generator = ReaderT Env (WriterT Output (Except ErrorMsg)) -#else -type Generator = ReaderT Env (WriterT Output (Either ErrorMsg)) -#endif -- | Context information for generating Haskell code. data Env = Env @@ -289,15 +248,15 @@ -- | Returns the currently generating interface. askInterface :: Generator Interface -askInterface = envInterface <$> ask +askInterface = asks envInterface -- | Returns the currently generating module. askModule :: Generator Module -askModule = envModule <$> ask +askModule = asks envModule -- | Returns the currently generating module's Haskell module name. askModuleName :: Generator String -askModuleName = envModuleName <$> ask +askModuleName = asks envModuleName -- | Looks up the 'Module' containing a given external name, throwing an error -- if it can't be found. @@ -305,7 +264,7 @@ getModuleForExtName extName = inFunction "getModuleForExtName" $ do iface <- askInterface case M.lookup extName $ interfaceNamesToModules iface of - Just mod -> return mod + Just m -> return m Nothing -> throwError $ "Can't find module for " ++ show extName -- | A partially-rendered 'Module'. Contains all of the module's bindings, but @@ -359,22 +318,20 @@ -- Returns an error message if an error occurred, otherwise the action's output -- together with its value. runGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg (Partial, a) -runGenerator iface mod generator = - let modName = getModuleName iface mod +runGenerator iface m generator = + let modName = getModuleName iface m in fmap (first (Partial modName) . swap) $ -#if MIN_VERSION_mtl(2,2,1) runExcept $ -#endif flip catchError (\msg -> throwError $ msg ++ ".") $ - runWriterT $ runReaderT generator $ Env iface mod modName + runWriterT $ runReaderT generator $ Env iface m modName -- | Runs a generator action and returns the its value. evalGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg a -evalGenerator iface mod = fmap snd . runGenerator iface mod +evalGenerator iface m = fmap snd . runGenerator iface m -- | Runs a generator action and returns its output. execGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg Partial -execGenerator iface mod = fmap fst . runGenerator iface mod +execGenerator iface m = fmap fst . runGenerator iface m -- | Converts a 'Partial' into a complete Haskell module. renderPartial :: Partial -> String @@ -441,6 +398,33 @@ addExtension extensionName = tell $ mempty { outputExtensions = S.singleton extensionName } +-- | The section of code that Hoppy is generating, for an export. +data SayExportMode = + SayExportForeignImports + -- ^ Hoppy is generating @foreign import@ statements for an export. This is + -- separate from the main 'SayExportDecls' phase because foreign import + -- statements are emitted directly by a 'Generator', and these need to + -- appear earlier in the code. + | SayExportDecls + -- ^ Hoppy is generating Haskell code to bind to the export. This is the + -- main step of Haskell code generation for an export. + -- + -- Here, imports of Haskell modules should be added with 'LH.addImports' + -- rather than emitting an @import@ statement yourself in the foreign import + -- step. 'LH.addExtNameModule' may be used to import and reference the + -- Haskell module of another export. + | SayExportBoot + -- ^ If Hoppy needs to generate @hs-boot@ files to break circular + -- dependences between generated modules, then for each export in each + -- module involved in a cycle, it will call the generator in this mode to + -- produce @hs-boot@ code. This code should provide a minimal declaration + -- of Haskell entities generated by 'SayExportDecls', without providing any + -- implementation. + -- + -- For information on the special format of @hs-boot@ files, see the + -- . + deriving (Eq, Show) + -- | Outputs a line of Haskell code. A newline will be added on the end of the -- input. Newline characters must not be given to this function. sayLn :: String -> Generator () @@ -493,6 +477,8 @@ sayLn "in" indent body +-- | Looks up the module that exports an external name. Throws an error if the +-- external name is not exported. getExtNameModule :: ExtName -> Generator Module getExtNameModule extName = inFunction "getExtNameModule" $ do iface <- askInterface @@ -504,11 +490,11 @@ -- | Returns a module's unique short name that should be used for a qualified -- import of the module. getModuleImportName :: Module -> Generator String -getModuleImportName mod = do +getModuleImportName m = do iface <- askInterface - fromMaybeM (throwError $ "Couldn't find a Haskell import name for " ++ show mod ++ + fromMaybeM (throwError $ "Couldn't find a Haskell import name for " ++ show m ++ " (is it included in the interface's module list?)") $ - M.lookup mod $ + M.lookup m $ interfaceHaskellModuleImportNames iface -- | Adds a qualified import of the given external name's module into the current @@ -538,9 +524,9 @@ Nothing -> hsEntity -- Same module. Just importName -> concat [importName, ".", hsEntity] -- Different module. --- | Internal helper function for constructing Haskell names from external --- names. Returns a name that is a suitable Haskell type name for the external --- name, and if given 'Const', then with @\"Const\"@ appended. +-- | Constructs Haskell names from external names. Returns a name that is a +-- suitable Haskell type name for the external name, and if given 'Const', then +-- with @\"Const\"@ appended. toHsTypeName :: Constness -> ExtName -> Generator String toHsTypeName cst extName = inFunction "toHsTypeName" $ @@ -556,299 +542,6 @@ x:xs -> toUpper x:xs [] -> [] --- | Returns the Haskell name for an enum. -toHsEnumTypeName :: CppEnum -> Generator String -toHsEnumTypeName enum = - inFunction "toHsEnumTypeName" $ - addExtNameModule (enumExtName enum) $ toHsEnumTypeName' enum - --- | Pure version of 'toHsEnumTypeName' that doesn't create a qualified name. -toHsEnumTypeName' :: CppEnum -> String -toHsEnumTypeName' = toHsTypeName' Nonconst . enumExtName - --- | Constructs the data constructor name for a value in an enum. Like C++ and --- unlike say Java, Haskell enum values aren't in a separate enum-specific --- namespace, so we prepend the enum name to the value name to get the data --- constructor name. The value name is a list of words; see 'enumValueNames'. -toHsEnumCtorName :: CppEnum -> [String] -> Generator String -toHsEnumCtorName enum words = - inFunction "toHsEnumCtorName" $ - addExtNameModule (enumExtName enum) $ toHsEnumCtorName' enum words - --- | Pure version of 'toHsEnumCtorName' that doesn't create a qualified name. -toHsEnumCtorName' :: CppEnum -> [String] -> String -toHsEnumCtorName' enum words = - concat $ enumValuePrefix enum : map capitalize words - --- | Returns the Haskell name for a bitspace. See 'toHsEnumTypeName'. -toHsBitspaceTypeName :: Bitspace -> Generator String -toHsBitspaceTypeName bitspace = - inFunction "toHsBitspaceTypeName" $ - addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceTypeName' bitspace - --- | Pure version of 'toHsBitspaceTypeName' that doesn't create a qualified name. -toHsBitspaceTypeName' :: Bitspace -> String -toHsBitspaceTypeName' = toHsTypeName' Nonconst . bitspaceExtName - --- | Constructs the data constructor name for a value in a bitspace. See --- 'toHsEnumCtorName'. -toHsBitspaceValueName :: Bitspace -> [String] -> Generator String -toHsBitspaceValueName bitspace words = - inFunction "toHsBitspaceValueName" $ - addExtNameModule (bitspaceExtName bitspace) $ - toHsBitspaceValueName' bitspace words - --- | Pure version of 'toHsBitspaceValueName' that doesn't create a qualified name. -toHsBitspaceValueName' :: Bitspace -> [String] -> String -toHsBitspaceValueName' bitspace words = - lowerFirst $ concat $ bitspaceValuePrefix bitspace : map capitalize words - --- | Returns the name of the function that will convert a bitspace value into a --- raw numeric value. -toHsBitspaceToNumName :: Bitspace -> Generator String -toHsBitspaceToNumName bitspace = - inFunction "toHsBitspaceToNumName" $ - addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceToNumName' bitspace - --- | Pure version of 'toHsBitspaceToNumName' that doesn't create a qualified name. -toHsBitspaceToNumName' :: Bitspace -> String -toHsBitspaceToNumName' = ("from" ++) . toHsBitspaceTypeName' - --- | The name of the Haskell typeclass that contains a method for converting to --- a bitspace value. -toHsBitspaceClassName :: Bitspace -> Generator String -toHsBitspaceClassName bitspace = - inFunction "toHsBitspaceClassName" $ - addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceClassName' bitspace - --- | Pure version of 'toHsBitspaceClassName' that doesn't create a qualified name. -toHsBitspaceClassName' :: Bitspace -> String -toHsBitspaceClassName' bitspace = 'I':'s':toHsBitspaceTypeName' bitspace - --- | The name of the method in the 'toHsBitspaceClassName' typeclass that --- constructs bitspace values. -toHsBitspaceFromValueName :: Bitspace -> Generator String -toHsBitspaceFromValueName bitspace = - inFunction "toHsBitspaceFromValueName" $ - addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceFromValueName' bitspace - --- | Pure version of 'toHsBitspaceFromValueName' that doesn't create a qualified name. -toHsBitspaceFromValueName' :: Bitspace -> String -toHsBitspaceFromValueName' = ("to" ++) . toHsBitspaceTypeName' - --- | The name for the typeclass of types that can be represented as values of --- the given C++ class. -toHsValueClassName :: Class -> Generator String -toHsValueClassName cls = - inFunction "toHsValueClassName" $ - addExtNameModule (classExtName cls) $ toHsValueClassName' cls - --- | Pure version of 'toHsValueClassName' that doesn't create a qualified name. -toHsValueClassName' :: Class -> String -toHsValueClassName' cls = toHsDataTypeName' Nonconst cls ++ "Value" - --- | The name of the method within the 'toHsValueClassName' typeclass for --- accessing an object of the type as a pointer. -toHsWithValuePtrName :: Class -> Generator String -toHsWithValuePtrName cls = - inFunction "toHsWithValuePtrName" $ - addExtNameModule (classExtName cls) $ toHsWithValuePtrName' cls - --- | Pure version of 'toHsWithValuePtrName' that doesn't create a qualified name. -toHsWithValuePtrName' :: Class -> String -toHsWithValuePtrName' cls = concat ["with", toHsDataTypeName' Nonconst cls, "Ptr"] - --- | The name for the typeclass of types that are (possibly const) pointers to --- objects of the given C++ class, or subclasses. -toHsPtrClassName :: Constness -> Class -> Generator String -toHsPtrClassName cst cls = - inFunction "toHsPtrClassName" $ - addExtNameModule (classExtName cls) $ toHsPtrClassName' cst cls - --- | Pure version of 'toHsPtrClassName' that doesn't create a qualified name. -toHsPtrClassName' :: Constness -> Class -> String -toHsPtrClassName' cst cls = toHsDataTypeName' cst cls ++ "Ptr" - --- | The name of the function that upcasts pointers to the specific class type --- and constness. -toHsCastMethodName :: Constness -> Class -> Generator String -toHsCastMethodName cst cls = - inFunction "toHsCastMethodName" $ - addExtNameModule (classExtName cls) $ toHsCastMethodName' cst cls - --- | Pure version of 'toHsCastMethodName' that doesn't create a qualified name. -toHsCastMethodName' :: Constness -> Class -> String -toHsCastMethodName' cst cls = "to" ++ toHsDataTypeName' cst cls - --- | The name of the typeclass that provides a method to downcast to a specific --- class type. See 'toHsDownCastMethodName'. -toHsDownCastClassName :: Constness -> Class -> Generator String -toHsDownCastClassName cst cls = - inFunction "toHsDownCastClassName" $ - addExtNameModule (classExtName cls) $ toHsDownCastClassName' cst cls - --- | Pure version of 'toHsDownCastClassName' that doesn't create a qualified --- name. -toHsDownCastClassName' :: Constness -> Class -> String -toHsDownCastClassName' cst cls = - concat [toHsDataTypeName' Nonconst cls, - "Super", - case cst of - Const -> "Const" - Nonconst -> ""] - --- | The name of the function that downcasts pointers to the specific class type --- and constness. -toHsDownCastMethodName :: Constness -> Class -> Generator String -toHsDownCastMethodName cst cls = - inFunction "toHsDownCastMethodName" $ - addExtNameModule (classExtName cls) $ toHsDownCastMethodName' cst cls - --- | Pure version of 'toHsDownCastMethodName' that doesn't create a qualified --- name. -toHsDownCastMethodName' :: Constness -> Class -> String -toHsDownCastMethodName' cst cls = "downTo" ++ toHsDataTypeName' cst cls - --- | The import name for the foreign function that casts between two specific --- pointer types. Used for upcasting and downcasting. --- --- We need to know which module the cast function resides in, and while we could --- look this up, the caller always knows, so we just have them pass it in. -toHsCastPrimitiveName :: Class -> Class -> Class -> Generator String -toHsCastPrimitiveName descendentClass from to = - inFunction "toHsCastPrimitiveName" $ - addExtNameModule (classExtName descendentClass) $ toHsCastPrimitiveName' from to - --- | Pure version of 'toHsCastPrimitiveName' that doesn't create a qualified --- name. -toHsCastPrimitiveName' :: Class -> Class -> String -toHsCastPrimitiveName' from to = - concat ["cast", toHsDataTypeName' Nonconst from, "To", toHsDataTypeName' Nonconst to] - --- | The name of one of the functions that add/remove const to/from a class's --- pointer type. Given 'Const', it will return the function that adds const, --- and given 'Nonconst', it will return the function that removes const. -toHsConstCastFnName :: Constness -> Class -> Generator String -toHsConstCastFnName cst cls = - inFunction "toHsConstCastFnName" $ - addExtNameModule (classExtName cls) $ toHsConstCastFnName' cst cls - --- | Pure version of 'toHsConstCastFnName' that doesn't create a qualified name. -toHsConstCastFnName' :: Constness -> Class -> String -toHsConstCastFnName' cst cls = - concat ["cast", toHsDataTypeName' Nonconst cls, - case cst of - Const -> "ToConst" - Nonconst -> "ToNonconst"] - --- | The name of the data type that represents a pointer to an object of the --- given class and constness. -toHsDataTypeName :: Constness -> Class -> Generator String -toHsDataTypeName cst cls = - inFunction "toHsDataTypeName" $ - addExtNameModule (classExtName cls) $ toHsDataTypeName' cst cls - --- | Pure version of 'toHsDataTypeName' that doesn't create a qualified name. -toHsDataTypeName' :: Constness -> Class -> String -toHsDataTypeName' cst cls = toHsTypeName' cst $ classExtName cls - --- | The name of a data constructor for one of the object pointer types. -toHsDataCtorName :: Managed -> Constness -> Class -> Generator String -toHsDataCtorName m cst cls = - inFunction "toHsDataCtorName" $ - addExtNameModule (classExtName cls) $ toHsDataCtorName' m cst cls - --- | Pure version of 'toHsDataCtorName' that doesn't create a qualified name. -toHsDataCtorName' :: Managed -> Constness -> Class -> String -toHsDataCtorName' m cst cls = case m of - Unmanaged -> base - Managed -> base ++ "Gc" - where base = toHsDataTypeName' cst cls - --- | The name of the foreign function import wrapping @delete@ for the given --- class type. This is in internal to the binding; normal users should use --- 'Foreign.Hoppy.Runtime.delete'. --- --- This is internal to a generated Haskell module, so it does not have a public --- (qualified) form. -toHsClassDeleteFnName' :: Class -> String -toHsClassDeleteFnName' cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName' Nonconst cls - --- | The name of the foreign import that imports the same function as --- 'toHsClassDeleteFnName', but as a 'Foreign.Ptr.FunPtr' rather than an actual --- function. --- --- This is internal to a generated Haskell module, so it does not have a public --- (qualified) form. -toHsClassDeleteFnPtrName' :: Class -> String -toHsClassDeleteFnPtrName' cls = - 'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName' Nonconst cls - --- | Returns the name of the Haskell function that invokes the given --- constructor. -toHsCtorName :: Class -> Ctor -> Generator String -toHsCtorName cls ctor = - inFunction "toHsCtorName" $ - toHsClassEntityName cls $ fromExtName $ ctorExtName ctor - --- | Pure version of 'toHsCtorName' that doesn't create a qualified name. -toHsCtorName' :: Class -> Ctor -> String -toHsCtorName' cls ctor = - toHsClassEntityName' cls $ fromExtName $ ctorExtName ctor - --- | Returns the name of the Haskell function that invokes the given method. -toHsMethodName :: Class -> Method -> Generator String -toHsMethodName cls method = - inFunction "toHsMethodName" $ - toHsClassEntityName cls $ fromExtName $ methodExtName method - --- | Pure version of 'toHsMethodName' that doesn't create a qualified name. -toHsMethodName' :: Class -> Method -> String -toHsMethodName' cls method = - toHsClassEntityName' cls $ fromExtName $ methodExtName method - --- | Returns the name of the Haskell function for an entity in a class. -toHsClassEntityName :: IsFnName String name => Class -> name -> Generator String -toHsClassEntityName cls name = - addExtNameModule (classExtName cls) $ toHsClassEntityName' cls name - --- | Pure version of 'toHsClassEntityName' that doesn't create a qualified name. -toHsClassEntityName' :: IsFnName String name => Class -> name -> String -toHsClassEntityName' cls name = - lowerFirst $ fromExtName $ - classEntityForeignName' cls $ - case toFnName name of - FnName name -> toExtName name - FnOp op -> operatorPreferredExtName op - --- | The name of the function that takes a Haskell function and wraps it in a --- callback object. This is internal to the binding; normal users can pass --- Haskell functions to be used as callbacks inplicitly. -toHsCallbackCtorName :: Callback -> Generator String -toHsCallbackCtorName callback = - inFunction "toHsCallbackCtorName" $ - addExtNameModule (callbackExtName callback) $ toHsCallbackCtorName' callback - --- | Pure version of 'toHsCallbackCtorName' that doesn't create a qualified --- name. -toHsCallbackCtorName' :: Callback -> String -toHsCallbackCtorName' callback = - toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_new" - --- | The name of the function that takes a Haskell function with Haskell-side --- types and wraps it in a 'Foreign.Ptr.FunPtr' that does appropriate --- conversions to and from C-side types. -toHsCallbackNewFunPtrFnName :: Callback -> Generator String -toHsCallbackNewFunPtrFnName callback = - inFunction "toHsCallbackNewFunPtrFnName" $ - addExtNameModule (callbackExtName callback) $ toHsCallbackNewFunPtrFnName' callback - --- | Pure version of 'toHsCallbackNewFunPtrFnName' that doesn't create a qualified --- name. -toHsCallbackNewFunPtrFnName' :: Callback -> String -toHsCallbackNewFunPtrFnName' callback = - toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_newFunPtr" - -- | Converts an external name into a name suitable for a Haskell function or -- variable. toHsFnName :: ExtName -> Generator String @@ -879,51 +572,6 @@ withErrorContext (concat ["converting ", show t, " to ", show side, " type"]) $ case t of Internal_TVoid -> return $ HsTyCon $ Special HsUnitCon - -- C++ has sizeof(bool) == 1, whereas Haskell can > 1, so we have to convert. - Internal_TBool -> case side of - HsCSide -> addImports hsImportForRuntime $> HsTyCon (UnQual $ HsIdent "HoppyFHR.CBool") - HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Bool") - Internal_TChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CChar") - Internal_TUChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUChar") - Internal_TShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CShort") - Internal_TUShort -> - addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUShort") - Internal_TInt -> case side of - HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CInt") - HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Int") - Internal_TUInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUInt") - Internal_TLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLong") - Internal_TULong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULong") - Internal_TLLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLLong") - Internal_TULLong -> - addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULLong") - Internal_TFloat -> case side of - HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CFloat") - HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Float") - Internal_TDouble -> case side of - HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CDouble") - HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Double") - Internal_TInt8 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int8") - Internal_TInt16 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int16") - Internal_TInt32 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int32") - Internal_TInt64 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int64") - Internal_TWord8 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word8") - Internal_TWord16 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word16") - Internal_TWord32 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word32") - Internal_TWord64 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word64") - Internal_TPtrdiff -> - addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CPtrdiff") - Internal_TSize -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CSize") - Internal_TSSize -> - addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize") - Internal_TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of - HsCSide -> addImports hsImportForForeignC $> "HoppyFC.CInt" - HsHsSide -> toHsEnumTypeName e - Internal_TBitspace b -> case side of - HsCSide -> cppTypeToHsTypeAndUse side $ bitspaceType b - HsHsSide -> do - typeName <- toHsBitspaceTypeName b - return $ HsTyCon $ UnQual $ HsIdent typeName Internal_TPtr (Internal_TObj cls) -> do -- Same as TPtr (TConst (TObj cls)), but nonconst. typeName <- toHsTypeName Nonconst $ classExtName cls @@ -951,19 +599,12 @@ -- to use the C-side type of the pointer target here. HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") <$> cppTypeToHsTypeAndUse HsCSide t' Internal_TRef t' -> cppTypeToHsTypeAndUse side $ ptrT t' - Internal_TFn paramTypes retType -> do - paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes + Internal_TFn params retType -> do + paramHsTypes <- mapM (cppTypeToHsTypeAndUse side . parameterType) params retHsType <- cppTypeToHsTypeAndUse side retType addImports hsImportForPrelude return $ foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes - Internal_TCallback cb -> do - hsType <- cppTypeToHsTypeAndUse side =<< callbackToTFn side cb - case side of - HsHsSide -> return hsType - HsCSide -> do - addImports hsImportForRuntime - return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsType Internal_TObj cls -> case side of HsCSide -> cppTypeToHsTypeAndUse side $ ptrT $ constT t HsHsSide -> case classHaskellConversionType $ getClassHaskellConversion cls of @@ -977,31 +618,29 @@ Internal_TPtr _ -> cppTypeToHsTypeAndUse side t' Internal_TObj cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls _ -> throwError $ tToGcInvalidFormErrorMessage Nothing t' + Internal_TManual s -> case conversionSpecHaskell s of + Just h -> case side of + HsHsSide -> conversionSpecHaskellHsType h + HsCSide -> fromMaybe (conversionSpecHaskellHsType h) $ + conversionSpecHaskellCType h + Nothing -> throwError $ show s ++ " defines no Haskell conversion" Internal_TConst t' -> cppTypeToHsTypeAndUse side t' -- | Returns the 'ClassHaskellConversion' of a class. getClassHaskellConversion :: Class -> ClassHaskellConversion getClassHaskellConversion = classHaskellConversion . classConversion --- | Constructs the function type for a callback. For Haskell, the type depends --- on the side; the C++ side has additional parameters. --- --- Keep this in sync with the C++ generator's version. -callbackToTFn :: HsTypeSide -> Callback -> Generator Type -callbackToTFn side cb = do - needsExcParams <- case side of - HsCSide -> mayThrow - HsHsSide -> return False - return $ Internal_TFn ((if needsExcParams then addExcParams else id) $ callbackParams cb) - (callbackReturn cb) - - where mayThrow = case callbackThrows cb of - Just t -> return t - Nothing -> moduleCallbacksThrow <$> askModule >>= \mt -> case mt of - Just t -> return t - Nothing -> interfaceCallbacksThrow <$> askInterface - - addExcParams = (++ [ptrT intT, ptrT $ ptrT voidT]) +-- | Combines the given exception handlers (from a particular exported entity) +-- with the handlers from the current module and interface. The given handlers +-- have highest precedence, followed by module handlers, followed by interface +-- handlers. +getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers +getEffectiveExceptionHandlers handlers = do + ifaceHandlers <- interfaceExceptionHandlers <$> askInterface + moduleHandlers <- getExceptionHandlers <$> askModule + -- Exception handlers declared lower in the hierarchy take precedence over + -- those higher in the hierarchy; ExceptionHandlers is a left-biased monoid. + return $ mconcat [handlers, moduleHandlers, ifaceHandlers] -- | Prints a value like 'P.prettyPrint', but removes newlines so that they -- don't cause problems with this module's textual generation. Should be mainly diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot b/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot --- a/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot +++ b/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -18,30 +18,37 @@ {-# LANGUAGE CPP #-} module Foreign.Hoppy.Generator.Language.Haskell ( + Managed, Generator, Output, + SayExportMode, + withErrorContext, + addImports, + sayLn, prettyPrint, ) where -#if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except (Except) -#endif import Control.Monad.Reader (ReaderT) import Control.Monad.Writer (WriterT) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid) -#endif +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Base (HsImportSet) import qualified Language.Haskell.Pretty as P -#if MIN_VERSION_mtl(2,2,1) +data Managed = Unmanaged | Managed + type Generator = ReaderT Env (WriterT Output (Except String)) -#else -type Generator = ReaderT Env (WriterT Output (Either String)) -#endif data Env data Output instance Monoid Output + +data SayExportMode + +withErrorContext :: String -> Generator a -> Generator a + +addImports :: HsImportSet -> Generator () + +sayLn :: String -> Generator () prettyPrint :: P.Pretty a => a -> String diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs @@ -1,1694 +1,204 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner --- --- 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 . - -{-# LANGUAGE CPP #-} - --- | Internal portion of the Haskell code generator. -module Foreign.Hoppy.Generator.Language.Haskell.Internal ( - Generation, - generate, - generatedFiles, - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>), pure) -#endif -import Control.Arrow ((&&&)) -import Control.Monad (forM, unless, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except (throwError) -#else -import Control.Monad.Error (throwError) -#endif -import Control.Monad.Trans (lift) -import Control.Monad.Writer (execWriterT, tell) -import Data.Foldable (forM_) -import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp) -import Data.List (intersperse) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mconcat, mempty) -#endif -import qualified Data.Set as S -import Foreign.Hoppy.Generator.Common -import Foreign.Hoppy.Generator.Spec -import Foreign.Hoppy.Generator.Types -import Foreign.Hoppy.Generator.Language.Cpp ( - classCastFnCppName, - classDeleteFnCppName, - externalNameToCpp, - ) -import Foreign.Hoppy.Generator.Language.Haskell -import Language.Haskell.Syntax ( - HsAsst, - HsContext, - HsName (HsIdent), - HsQName (Special, UnQual), - HsQualType (HsQualType), - HsSpecialCon (HsUnitCon), - HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar), - ) -import System.FilePath ((<.>), pathSeparator) - --- | The in-memory result of generating Haskell code for an interface. -data Generation = Generation - { generatedFiles :: M.Map FilePath String - -- ^ A map from paths of generated files to the contents of those files. - -- The file paths are relative paths below the Haskell generation root. - } - --- | Runs the C++ code generator against an interface. -generate :: Interface -> Either ErrorMsg Generation -generate iface = do - -- Build the partial generation of each module. - modPartials <- forM (M.elems $ interfaceModules iface) $ \m -> - (,) m <$> execGenerator iface m (generateSource m) - - -- Compute the strongly connected components. If there is a nontrivial SCC, - -- then there is a module import cycle that we'll have to break with hs-boot - -- files. - let partialsByHsName :: M.Map HsModuleName Partial - partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials - - sccInput :: [((Module, Partial), Partial, [Partial])] - sccInput = for modPartials $ \x@(_, p) -> - (x, p, - mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $ - M.keys $ getHsImportSet $ outputImports $ partialOutput p) - - sccs :: [SCC (Module, Partial)] - sccs = stronglyConnComp sccInput - - fileContents <- execWriterT $ forM_ sccs $ \scc -> case scc of - AcyclicSCC (_, p) -> tell [finishPartial p "hs"] - CyclicSCC mps -> do - let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps - forM_ mps $ \(m, p) -> do - -- Create a boot partial. - pBoot <- lift $ execGenerator iface m (generateBootSource m) - - -- Change the source and boot partials so that all imports of modules in - -- this cycle are {-# SOURCE #-} imports. - let p' = setSourceImports cycleModNames p - pBoot' = setSourceImports cycleModNames pBoot - - -- Emit the completed partials. - tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"] - - return $ Generation $ M.fromList fileContents - - where finishPartial :: Partial -> String -> (FilePath, String) - finishPartial p fileExt = - (listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt, - prependExtensions $ renderPartial p) - - setSourceImports :: S.Set HsModuleName -> Partial -> Partial - setSourceImports modulesToSourceImport p = - let output = partialOutput p - imports = outputImports output - imports' = makeHsImportSet $ - M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $ - getHsImportSet imports - output' = output { outputImports = imports' } - in p { partialOutput = output' } - - setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs - setSourceImportIfIn modulesToSourceImport key specs = - if hsImportModule key `S.member` modulesToSourceImport - then specs { hsImportSource = True } - else specs - -prependExtensions :: String -> String -prependExtensions = (prependExtensionsPrefix ++) - -prependExtensionsPrefix :: String -prependExtensionsPrefix = - -- MultiParamTypeClasses is necessary for instances of Decodable and - -- Encodable. FlexibleContexts is needed for the type signature of the - -- function that wraps the actual callback function in callback creation - -- functions. - -- - -- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions - -- to and from String, which is really [Char]. - -- - -- UndecidableInstances is needed for instances of the form "SomeClassConstPtr - -- a => SomeClassValue a" (overlapping instances are used here too). - -- - -- GeneralizedNewtypeDeriving is to enable automatic deriving of - -- Data.Bits.Bits instances for bitspace newtypes. - concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}\n"] - where extensions = - [ "FlexibleContexts" - , "FlexibleInstances" - , "ForeignFunctionInterface" - , "GeneralizedNewtypeDeriving" - , "MonoLocalBinds" - , "MultiParamTypeClasses" - , "ScopedTypeVariables" - , "TypeSynonymInstances" - , "UndecidableInstances" - ] - -generateSource :: Module -> Generator () -generateSource m = do - forM_ (moduleExports m) $ sayExport SayExportForeignImports - forM_ (moduleExports m) $ sayExport SayExportDecls - - iface <- askInterface - when (interfaceExceptionSupportModule iface == Just m) $ - sayExceptionSupport True - - addendumHaskell $ getAddendum m - -generateBootSource :: Module -> Generator () -generateBootSource m = do - forM_ (moduleExports m) $ sayExport SayExportBoot - - iface <- askInterface - when (interfaceExceptionSupportModule iface == Just m) $ - sayExceptionSupport False - -data SayExportMode = SayExportForeignImports | SayExportDecls | SayExportBoot - deriving (Eq, Show) - -sayExport :: SayExportMode -> Export -> Generator () -sayExport mode export = do - case export of - ExportVariable v -> sayExportVar mode v - ExportEnum enum -> sayExportEnum mode enum - ExportBitspace bitspace -> sayExportBitspace mode bitspace - ExportFn fn -> - (sayExportFn mode <$> fnExtName <*> fnExtName <*> fnPurity <*> - fnParams <*> fnReturn <*> fnExceptionHandlers) fn - ExportClass cls -> sayExportClass mode cls - ExportCallback cb -> sayExportCallback mode cb - - when (mode == SayExportDecls) $ - addendumHaskell $ exportAddendum export - -sayExportVar :: SayExportMode -> Variable -> Generator () -sayExportVar mode v = withErrorContext ("generating variable " ++ show (varExtName v)) $ do - let getterName = varGetterExtName v - setterName = varSetterExtName v - sayExportVar' mode (varType v) Nothing True getterName getterName setterName setterName - -sayExportClassVar :: SayExportMode -> Class -> ClassVariable -> Generator () -sayExportClassVar mode cls v = - withErrorContext ("generating variable " ++ show (classVarExtName v)) $ - sayExportVar' mode - (classVarType v) - (case classVarStatic v of - Nonstatic -> Just cls - Static -> Nothing) - (classVarGettable v) - (classVarGetterExtName cls v) - (classVarGetterForeignName cls v) - (classVarSetterExtName cls v) - (classVarSetterForeignName cls v) - -sayExportVar' :: SayExportMode - -> Type - -> Maybe Class - -> Bool - -> ExtName - -> ExtName - -> ExtName - -> ExtName - -> Generator () -sayExportVar' mode - t - classIfNonstatic - gettable - getterExtName - getterForeignName - setterExtName - setterForeignName = do - let (isConst, deconstType) = case t of - Internal_TConst t -> (True, t) - t -> (False, t) - - when gettable $ - sayExportFn mode - getterExtName - getterForeignName - Nonpure - (maybe [] (\cls -> [ptrT $ constT $ objT cls]) classIfNonstatic) - deconstType - mempty - - unless isConst $ - sayExportFn mode - setterExtName - setterForeignName - Nonpure - (maybe [deconstType] (\cls -> [ptrT $ objT cls, deconstType]) - classIfNonstatic) - voidT - mempty - -sayExportEnum :: SayExportMode -> CppEnum -> Generator () -sayExportEnum mode enum = - withErrorContext ("generating enum " ++ show (enumExtName enum)) $ - case mode of - -- Nothing to import from the C++ side of an enum. - SayExportForeignImports -> return () - - SayExportDecls -> do - hsTypeName <- toHsEnumTypeName enum - values <- forM (enumValueNames enum) $ \(value, name) -> do - ctorName <- toHsEnumCtorName enum name - return (value, ctorName) - addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude] - - -- Print out the data declaration. - ln - addExport' hsTypeName - saysLn ["data ", hsTypeName, " ="] - indent $ do - forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) -> - saysLn [if cont then "| " else "", hsCtorName] - sayLn "deriving (HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)" - - -- Print out the Enum instance. - ln - saysLn ["instance HoppyP.Enum ", hsTypeName, " where"] - indent $ do - forM_ values $ \(num, hsCtorName) -> - saysLn ["fromEnum ", hsCtorName, " = ", show num] - ln - forM_ values $ \(num, hsCtorName) -> - saysLn ["toEnum (", show num, ") = ", hsCtorName] - saysLn ["toEnum n' = HoppyP.error $ ", - show (concat ["Unknown ", hsTypeName, " numeric value: "]), - " ++ HoppyP.show n'"] - - SayExportBoot -> do - hsTypeName <- toHsEnumTypeName enum - addImports hsImportForPrelude - addExport hsTypeName - ln - saysLn ["data ", hsTypeName] - saysLn ["instance HoppyP.Bounded ", hsTypeName] - saysLn ["instance HoppyP.Enum ", hsTypeName] - saysLn ["instance HoppyP.Eq ", hsTypeName] - saysLn ["instance HoppyP.Ord ", hsTypeName] - saysLn ["instance HoppyP.Show ", hsTypeName] - -sayExportBitspace :: SayExportMode -> Bitspace -> Generator () -sayExportBitspace mode bitspace = - withErrorContext ("generating bitspace " ++ show (bitspaceExtName bitspace)) $ do - hsTypeName <- toHsBitspaceTypeName bitspace - fromFnName <- toHsBitspaceToNumName bitspace - className <- toHsBitspaceClassName bitspace - toFnName <- toHsBitspaceFromValueName bitspace - let hsType = HsTyCon $ UnQual $ HsIdent hsTypeName - case mode of - -- Nothing to import from the C++ side of a bitspace. - SayExportForeignImports -> return () - - SayExportDecls -> do - values <- forM (bitspaceValueNames bitspace) $ \(value, name) -> do - bindingName <- toHsBitspaceValueName bitspace name - return (value, bindingName) - - hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace - hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace - - -- Print out the data declaration and conversion functions. - addImports $ mconcat [hsImportForBits, hsImportForPrelude, hsImportForRuntime] - addExport' hsTypeName - addExport' className - ln - saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ", - fromFnName, " :: ", prettyPrint hsCNumType, " }"] - indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)" - ln - saysLn ["class ", className, " a where"] - indent $ do - let tyVar = HsTyVar $ HsIdent "a" - saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType] - ln - saysLn ["instance ", className, " (", prettyPrint hsCNumType, ") where"] - indent $ saysLn [toFnName, " = ", hsTypeName] - when (hsHsNumType /= hsCNumType) $ do - saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"] - indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"] - saysLn ["instance ", className, " ", hsTypeName, " where"] - indent $ saysLn [toFnName, " = HoppyP.id"] - - -- If the bitspace has an associated enum, then print out a conversion - -- instance for it as well. - forM_ (bitspaceEnum bitspace) $ \enum -> do - enumTypeName <- toHsEnumTypeName enum - addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime] - ln - saysLn ["instance ", className, " ", enumTypeName, " where"] - indent $ - saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"] - - -- Print out the constants. - ln - forM_ values $ \(num, valueName) -> do - addExport valueName - saysLn [valueName, " = ", hsTypeName, " (", show num, ")"] - - SayExportBoot -> do - hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace - hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace - - addImports $ mconcat [hsImportForBits, hsImportForPrelude] - addExport' hsTypeName - addExport' className - ln - saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ", - fromFnName, " :: ", prettyPrint hsCNumType, " }"] - ln - saysLn ["instance HoppyDB.Bits ", hsTypeName] - saysLn ["instance HoppyP.Bounded ", hsTypeName] - saysLn ["instance HoppyP.Eq ", hsTypeName] - saysLn ["instance HoppyP.Ord ", hsTypeName] - saysLn ["instance HoppyP.Show ", hsTypeName] - ln - saysLn ["class ", className, " a where"] - indent $ do - let tyVar = HsTyVar $ HsIdent "a" - saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType] - ln - saysLn ["instance ", className, " (", prettyPrint hsCNumType, ")"] - when (hsHsNumType /= hsCNumType) $ - saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"] - saysLn ["instance ", className, " ", hsTypeName] - forM_ (bitspaceEnum bitspace) $ \enum -> do - enumTypeName <- toHsEnumTypeName enum - saysLn ["instance ", className, " ", enumTypeName] - -sayExportFn :: SayExportMode - -> ExtName - -> ExtName - -> Purity - -> [Type] - -> Type - -> ExceptionHandlers - -> Generator () -sayExportFn mode extName foreignName purity paramTypes retType exceptionHandlers = do - effectiveHandlers <- getEffectiveExceptionHandlers exceptionHandlers - let handlerList = exceptionHandlersList effectiveHandlers - catches = not $ null handlerList - - -- We use the pure version of toHsFnName here; because foreignName isn't an - -- ExtName present in the interface's lookup table, toHsFnName would bail on - -- it. Since functions don't reference each other (e.g. we don't put anything - -- in .hs-boot files for them in circular modules cases), this isn't a problem. - let hsFnName = toHsFnName' foreignName - hsFnImportedName = hsFnName ++ "'" - - case mode of - SayExportForeignImports -> - withErrorContext ("generating imports for function " ++ show extName) $ do - -- Print a "foreign import" statement. - hsCType <- fnToHsTypeAndUse HsCSide purity paramTypes retType effectiveHandlers - saysLn ["foreign import ccall \"", externalNameToCpp extName, "\" ", hsFnImportedName, - " :: ", prettyPrint hsCType] - - SayExportDecls -> withErrorContext ("generating function " ++ show extName) $ do - -- Print the type signature. - ln - addExport hsFnName - hsHsType <- fnToHsTypeAndUse HsHsSide purity paramTypes retType effectiveHandlers - saysLn [hsFnName, " :: ", prettyPrint hsHsType] - - case purity of - Nonpure -> return () - Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"] - - -- Print the function body. - let argNames = map toArgName [1..length paramTypes] - convertedArgNames = map (++ "'") argNames - -- Operators on this line must bind more weakly than operators used below, - -- namely ($) and (>>=). (So finish the line with ($).) - lineEnd <- case purity of - Nonpure -> return [" ="] - Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO] - return [" = HoppySIU.unsafePerformIO $"] - saysLn $ hsFnName : map (' ':) argNames ++ lineEnd - indent $ do - forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') -> - sayArgProcessing ToCpp t argName argName' - - exceptionHandling <- - if catches - then do iface <- askInterface - currentModule <- askModule - let exceptionSupportModule = interfaceExceptionSupportModule iface - when (exceptionSupportModule /= Just currentModule) $ - addImports . hsWholeModuleImport . getModuleName iface =<< - fromMaybeM (throwError - "Internal error, an exception support module is not available") - exceptionSupportModule - addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime] - return "HoppyFHR.internalHandleExceptions exceptionDb' $" - else return "" - - let callWords = exceptionHandling : hsFnImportedName : map (' ':) convertedArgNames - sayCallAndProcessReturn ToCpp retType callWords - - SayExportBoot -> - -- Functions (methods included) cannot be referenced from other exports, - -- so we don't need to emit anything. - -- - -- If this changes, revisit the comment on hsFnName above. - return () - --- | Prints \"foreign import\" statements and an internal callback construction --- function for a given 'Callback' specification. For example, for a callback --- of 'HsHsSide' type @Int -> String -> IO Int@, we will generate the following --- bindings: --- --- > foreign import ccall "wrapper" name'newFunPtr --- > :: (CInt -> Ptr CChar -> IO CInt) --- > -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt)) --- > --- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.) --- > foreign import ccall "genpop__name_impl" name'newCallback --- > :: FunPtr (CInt -> Ptr CChar -> IO CInt) --- > -> FunPtr (FunPtr (IO ()) -> IO ()) --- > -> Bool --- > -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) --- > --- > name_newFunPtr :: (Int -> String -> IO Int) -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt)) --- > name_newFunPtr f'hs = name'newFunPtr $ \excIdPtr excPtrPtr arg1 arg2 -> --- > internalHandleCallbackExceptions excIdPtr excPtrPtr $ --- > coerceIntegral arg1 >>= \arg1' -> --- > (...decode the C string) >>= \arg2' -> --- > fmap coerceIntegral --- > (f'hs arg1' arg2') --- > --- > name_new :: (Int -> String -> IO Int) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) --- > name_new f = do --- > f'p <- name_newFunPtr f --- > name'newCallback f'p freeHaskellFunPtrFunPtr False -sayExportCallback :: SayExportMode -> Callback -> Generator () -sayExportCallback mode cb = - withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do - let name = callbackExtName cb - paramTypes = callbackParams cb - retType = callbackReturn cb - hsNewFunPtrFnName <- toHsCallbackNewFunPtrFnName cb - hsCtorName <- toHsCallbackCtorName cb - let hsCtorName'newCallback = hsCtorName ++ "'newCallback" - hsCtorName'newFunPtr = hsCtorName ++ "'newFunPtr" - - hsFnCType <- cppTypeToHsTypeAndUse HsCSide =<< callbackToTFn HsCSide cb - hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide =<< callbackToTFn HsHsSide cb - - let getWholeNewFunPtrFnType = do - addImports $ mconcat [hsImportForForeign, hsImportForPrelude] - return $ - HsTyFun hsFnHsType $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType - getWholeCtorType = do - addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] - return $ - HsTyFun hsFnHsType $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType - - case mode of - SayExportForeignImports -> do - addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime] - let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType - hsFunPtrImportType = - HsTyFun hsFnCType $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType - hsCallbackCtorImportType = - HsTyFun hsFunPtrType $ - HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $ - HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ - HsTyCon $ Special HsUnitCon) $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ - HsTyCon $ Special HsUnitCon) $ - HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ - HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType - - saysLn ["foreign import ccall \"wrapper\" ", hsCtorName'newFunPtr, " :: ", - prettyPrint hsFunPtrImportType] - saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ", - hsCtorName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType] - - SayExportDecls -> do - addExports [hsNewFunPtrFnName, hsCtorName] - - -- Generate the *_newFunPtr function. - wholeNewFunPtrFnType <- getWholeNewFunPtrFnType - let paramCount = length paramTypes - argNames = map toArgName [1..paramCount] - argNames' = map (++ "'") argNames - throws <- getEffectiveCallbackThrows cb - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForRuntime] - ln - saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType] - saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" : - case (if throws then (++ ["excIdPtr", "excPtrPtr"]) else id) argNames of - [] -> [] - argNames' -> [" \\", unwords argNames', " ->"] - indent $ do - when throws $ sayLn "HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $" - forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') -> - sayArgProcessing FromCpp t argName argName' - sayCallAndProcessReturn FromCpp retType $ - "f'hs" : map (' ':) argNames' - - -- Generate the *_new function. - wholeCtorType <- getWholeCtorType - ln - saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType] - saysLn [hsCtorName, " f'hs = do"] - indent $ do - saysLn ["f'p <- ", hsNewFunPtrFnName, " f'hs"] - saysLn [hsCtorName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"] - - SayExportBoot -> do - addExports [hsNewFunPtrFnName, hsCtorName] - wholeNewFunPtrFnType <- getWholeNewFunPtrFnType - wholeCtorType <- getWholeCtorType - ln - saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType] - ln - saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType] - -data CallDirection = - ToCpp -- ^ Haskell code is calling out to C++. - | FromCpp -- ^ C++ is invoking a callback. - -sayArgProcessing :: CallDirection -> Type -> String -> String -> Generator () -sayArgProcessing dir t fromVar toVar = - withErrorContext ("processing argument of type " ++ show t) $ - case t of - Internal_TVoid -> throwError $ "TVoid is not a valid argument type" - Internal_TBool -> case dir of - ToCpp -> saysLn ["let ", toVar, " = if ", fromVar, " then 1 else 0 in"] - FromCpp -> do addImports $ hsImport1 "Prelude" "(/=)" - saysLn ["let ", toVar, " = ", fromVar, " /= 0 in"] - Internal_TChar -> noConversion - Internal_TUChar -> noConversion - Internal_TShort -> noConversion - Internal_TUShort -> noConversion - Internal_TInt -> sayCoerceIntegral - Internal_TUInt -> noConversion - Internal_TLong -> noConversion - Internal_TULong -> noConversion - Internal_TLLong -> noConversion - Internal_TULLong -> noConversion - Internal_TFloat -> sayCoerceFloating - Internal_TDouble -> sayCoerceFloating - Internal_TInt8 -> noConversion - Internal_TInt16 -> noConversion - Internal_TInt32 -> noConversion - Internal_TInt64 -> noConversion - Internal_TWord8 -> noConversion - Internal_TWord16 -> noConversion - Internal_TWord32 -> noConversion - Internal_TWord64 -> noConversion - Internal_TPtrdiff -> noConversion - Internal_TSize -> noConversion - Internal_TSSize -> noConversion - Internal_TEnum _ -> do - addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForPrelude, hsImportForRuntime] - saysLn ["let ", toVar, - -- TODO The coersion here is unnecssary if we replace the C numeric - -- types with their Haskell ones across the board (e.g. CInt -> - -- Int). - case dir of - ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum " - FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ", - fromVar, " in"] - Internal_TBitspace b -> case dir of - ToCpp -> do - toNumName <- toHsBitspaceToNumName b - fromValueName <- toHsBitspaceFromValueName b - saysLn ["let ", toVar, " = ", toNumName, " $ ", fromValueName, " ", fromVar, " in"] - FromCpp -> do - typeName <- toHsBitspaceTypeName b - saysLn ["let ", toVar, " = " , typeName, " ", fromVar, " in"] - -- References and pointers are handled equivalently. - Internal_TPtr (Internal_TObj cls) -> case dir of - ToCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForRuntime] - castMethodName <- toHsCastMethodName Nonconst cls - saysLn ["HoppyFHR.withCppPtr (", castMethodName, " ", fromVar, - ") $ \\", toVar, " ->"] - FromCpp -> do - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"] - Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of - ToCpp -> do - -- Same as the (TObj _), ToCpp case. - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForPrelude, - hsImportForRuntime] - withValuePtrName <- toHsWithValuePtrName cls - saysLn [withValuePtrName, " ", fromVar, - " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] - FromCpp -> do - ctorName <- toHsDataCtorName Unmanaged Const cls - saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"] - Internal_TPtr _ -> noConversion - Internal_TRef t' -> sayArgProcessing dir (ptrT t') fromVar toVar - Internal_TFn {} -> throwError "TFn unimplemented" - Internal_TCallback cb -> case dir of - ToCpp -> do - addImports $ hsImport1 "Prelude" "(>>=)" - callbackCtorName <- toHsCallbackCtorName cb - saysLn [callbackCtorName, " ", fromVar, " >>= \\", toVar, " ->"] - FromCpp -> throwError "Can't receive a callback from C++" - Internal_TObj cls -> case dir of - ToCpp -> do - -- Same as the (TPtr (TConst (TObj _))), ToPtr case. - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForPrelude, - hsImportForRuntime] - withValuePtrName <- toHsWithValuePtrName cls - saysLn [withValuePtrName, " ", fromVar, - " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] - FromCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of - Just _ -> do - addImports $ mconcat [hsImport1 "Prelude" "(>>=)", - hsImportForRuntime] - ctorName <- toHsDataCtorName Unmanaged Const cls - saysLn ["HoppyFHR.decode (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"] - Nothing -> - throwError $ concat - ["Can't pass a TObj of ", show cls, - " from C++ to Haskell because no class decode conversion is defined"] - Internal_TObjToHeap cls -> case dir of - ToCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls - FromCpp -> sayArgProcessing dir (ptrT $ objT cls) fromVar toVar - Internal_TToGc t' -> case dir of - ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' - FromCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "(>>=)", - hsImportForRuntime] - ctorName <- - maybe (throwError $ tToGcInvalidFormErrorMessage Nothing t') - (toHsDataCtorName Unmanaged Nonconst) $ - case stripConst t' of - Internal_TObj cls -> Just cls - Internal_TRef (Internal_TConst (Internal_TObj cls)) -> Just cls - Internal_TRef (Internal_TObj cls) -> Just cls - Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> Just cls - Internal_TPtr (Internal_TObj cls) -> Just cls - _ -> Nothing - saysLn ["HoppyFHR.toGc (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"] - Internal_TConst t' -> sayArgProcessing dir t' fromVar toVar - where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"] - sayCoerceIntegral = do - addImports hsImportForRuntime - saysLn ["let ", toVar, " = HoppyFHR.coerceIntegral ", fromVar, " in"] - sayCoerceFloating = do - addImports hsImportForPrelude - saysLn ["let ", toVar, " = HoppyP.realToFrac ", fromVar, " in"] - --- | Note that the 'CallDirection' is the direction of the call, not the --- direction of the return. 'ToCpp' means we're returning to the foreign --- language, 'FromCpp' means we're returning from it. -sayCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator () -sayCallAndProcessReturn dir t callWords = - withErrorContext ("processing return value of type " ++ show t) $ - case t of - Internal_TVoid -> sayCall - Internal_TBool -> do - case dir of - ToCpp -> do addImports $ mconcat [hsImport1 "Prelude" "(/=)", hsImportForPrelude] - sayLn "HoppyP.fmap (/= 0)" - FromCpp -> sayLn "HoppyP.fmap (\\x -> if x then 1 else 0)" - sayCall - Internal_TChar -> sayCall - Internal_TUChar -> sayCall - Internal_TShort -> sayCall - Internal_TUShort -> sayCall - Internal_TInt -> sayCoerceIntegral >> sayCall - Internal_TUInt -> sayCall - Internal_TLong -> sayCall - Internal_TULong -> sayCall - Internal_TLLong -> sayCall - Internal_TULLong -> sayCall - Internal_TFloat -> sayCoerceFloating >> sayCall - Internal_TDouble -> sayCoerceFloating >> sayCall - Internal_TInt8 -> sayCall - Internal_TInt16 -> sayCall - Internal_TInt32 -> sayCall - Internal_TInt64 -> sayCall - Internal_TWord8 -> sayCall - Internal_TWord16 -> sayCall - Internal_TWord32 -> sayCall - Internal_TWord64 -> sayCall - Internal_TPtrdiff -> sayCall - Internal_TSize -> sayCall - Internal_TSSize -> sayCall - Internal_TEnum _ -> do - addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime] - case dir of - -- TODO The coersion here is unnecssary if we replace the C numeric types - -- with their Haskell ones across the board (e.g. CInt -> Int). - ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"] - FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"] - sayCall - Internal_TBitspace b -> do - addImports hsImportForPrelude - convFn <- bitspaceConvFn dir b - saysLn ["HoppyP.fmap ", convFn] - sayCall - -- The same as TPtr (TConst (TObj _)), but nonconst. - Internal_TPtr (Internal_TObj cls) -> do - case dir of - ToCpp -> do - addImports hsImportForPrelude - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - saysLn ["HoppyP.fmap ", ctorName] - sayCall - FromCpp -> do - addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] - sayLn "HoppyP.fmap HoppyFHR.toPtr" - sayCall - -- The same as TPtr (TConst (TObj _)), but nonconst. - Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of - ToCpp -> do - addImports hsImportForPrelude - ctorName <- toHsDataCtorName Unmanaged Const cls - saysLn ["HoppyP.fmap ", ctorName] - sayCall - FromCpp -> do - addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] - sayLn "HoppyP.fmap HoppyFHR.toPtr" - sayCall - Internal_TPtr _ -> sayCall - Internal_TRef t' -> sayCallAndProcessReturn dir (ptrT t') callWords - Internal_TFn {} -> throwError "TFn unimplemented" - Internal_TCallback cb -> case dir of - ToCpp -> throwError "Can't receive a callback from C++" - FromCpp -> do - addImports $ hsImport1 "Prelude" "(=<<)" - ctorName <- toHsCallbackCtorName cb - saysLn [ctorName, "=<<"] - sayCall - Internal_TObj cls -> case dir of - ToCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of - Just _ -> do - addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], - hsImportForRuntime] - ctorName <- toHsDataCtorName Unmanaged Const cls - saysLn ["(HoppyFHR.decodeAndDelete . ", ctorName, ") =<<"] - sayCall - Nothing -> - throwError $ concat - ["Can't return a TObj of ", show cls, - " from C++ to Haskell because no class decode conversion is defined"] - FromCpp -> do - addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], - hsImportForPrelude, - hsImportForRuntime] - sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<" - sayCall - Internal_TObjToHeap cls -> case dir of - ToCpp -> sayCallAndProcessReturn dir (ptrT $ objT cls) callWords - FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls - Internal_TToGc t' -> case dir of - ToCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "(=<<)", - hsImportForRuntime] - sayLn "HoppyFHR.toGc =<<" - -- TToGc (TObj _) should create a pointer rather than decoding, so we - -- change the TObj _ into a TPtr (TObj _). - case t' of - Internal_TObj _ -> sayCallAndProcessReturn dir (ptrT t') callWords - _ -> sayCallAndProcessReturn dir t' callWords - FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' - Internal_TConst t' -> sayCallAndProcessReturn dir t' callWords - where sayCall = saysLn $ "(" : callWords ++ [")"] - sayCoerceIntegral = do addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] - sayLn "HoppyP.fmap HoppyFHR.coerceIntegral" - sayCoerceFloating = do addImports hsImportForPrelude - sayLn "HoppyP.fmap HoppyP.realToFrac" - bitspaceConvFn dir = case dir of - ToCpp -> toHsBitspaceTypeName - FromCpp -> toHsBitspaceToNumName - -sayExportClass :: SayExportMode -> Class -> Generator () -sayExportClass mode cls = withErrorContext ("generating class " ++ show (classExtName cls)) $ do - case mode of - SayExportForeignImports -> do - sayExportClassHsVars mode cls - sayExportClassHsCtors mode cls - - forM_ (classMethods cls) $ \method -> - (sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*> - methodPurity <*> pure (getMethodEffectiveParams cls method) <*> - methodReturn <*> methodExceptionHandlers) - method - - SayExportDecls -> do - sayExportClassHsClass True cls Const - sayExportClassHsClass True cls Nonconst - - sayExportClassHsStaticMethods cls - - -- Create a newtype for referencing foreign objects with pointers. The - -- newtype is not used with encodings of value objects. - sayExportClassHsType True cls Const - sayExportClassHsType True cls Nonconst - - sayExportClassExceptionSupport True cls - - sayExportClassHsVars mode cls - sayExportClassHsCtors mode cls - - SayExportBoot -> do - sayExportClassHsClass False cls Const - sayExportClassHsClass False cls Nonconst - - sayExportClassHsType False cls Const - sayExportClassHsType False cls Nonconst - - sayExportClassExceptionSupport False cls - - sayExportClassHsVars mode cls - - sayExportClassCastPrimitives mode cls - sayExportClassHsSpecialFns mode cls - -sayExportClassHsClass :: Bool -> Class -> Constness -> Generator () -sayExportClassHsClass doDecls cls cst = withErrorContext "generating Haskell typeclass" $ do - hsTypeName <- toHsDataTypeName cst cls - hsValueClassName <- toHsValueClassName cls - hsWithValuePtrName <- toHsWithValuePtrName cls - hsPtrClassName <- toHsPtrClassName cst cls - hsCastMethodName <- toHsCastMethodName cst cls - let supers = classSuperclasses cls - - hsSupers <- - (\x -> if null x - then do addImports hsImportForRuntime - return ["HoppyFHR.CppPtr"] - else return x) =<< - case cst of - Const -> mapM (toHsPtrClassName Const) supers - Nonconst -> - (:) <$> toHsPtrClassName Const cls <*> mapM (toHsPtrClassName Nonconst) supers - - -- Print the value class definition. There is only one of these, and it is - -- spiritually closer to the const version of the pointers for this class, so - -- we emit for the const case only. - when (cst == Const) $ do - addImports hsImportForPrelude - addExport' hsValueClassName - ln - saysLn ["class ", hsValueClassName, " a where"] - indent $ - saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"] - - -- Generate instances for all pointer subtypes. - ln - saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a", - if doDecls then " where" else ""] - when doDecls $ do - addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"], - hsImportForPrelude] - indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName] - - -- When the class is encodable to a native Haskell type, also print an - -- instance for it. - let conv = getClassHaskellConversion cls - case (classHaskellConversionType conv, - classHaskellConversionToCppFn conv) of - (Just hsTypeGen, Just _) -> do - hsType <- hsTypeGen - ln - saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")", - if doDecls then " where" else ""] - when doDecls $ do - addImports hsImportForRuntime - indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"] - _ -> return () - - -- Print the pointer class definition. - addExport' hsPtrClassName - ln - saysLn $ - "class (" : - intersperse ", " (map (++ " this") hsSupers) ++ - [") => ", hsPtrClassName, " this where"] - indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName] - - -- Print the non-static methods. - when doDecls $ do - let methods = filter ((cst ==) . methodConst) $ classMethods cls - forM_ methods $ \method -> - when (methodStatic method == Nonstatic) $ - (sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*> - methodPurity <*> pure (getMethodEffectiveParams cls method) <*> - methodReturn <*> methodExceptionHandlers) method - -sayExportClassHsStaticMethods :: Class -> Generator () -sayExportClassHsStaticMethods cls = - forM_ (classMethods cls) $ \method -> - when (methodStatic method == Static) $ - (sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*> - methodPurity <*> methodParams <*> methodReturn <*> methodExceptionHandlers) method - -sayExportClassHsType :: Bool -> Class -> Constness -> Generator () -sayExportClassHsType doDecls cls cst = withErrorContext "generating Haskell data types" $ do - hsTypeName <- toHsDataTypeName cst cls - hsCtor <- toHsDataCtorName Unmanaged cst cls - hsCtorGc <- toHsDataCtorName Managed cst cls - constCastFnName <- toHsConstCastFnName cst cls - - addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime] - -- Unfortunately, we must export the data constructor, so that GHC can marshal - -- it in foreign calls in other modules. - addExport' hsTypeName - ln - saysLn ["data ", hsTypeName, " ="] - indent $ do - saysLn [" ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"] - saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"] - when doDecls $ do - addImports $ hsImport1 "Prelude" "(==)" - indent $ sayLn "deriving (HoppyP.Show)" - ln - saysLn ["instance HoppyP.Eq ", hsTypeName, " where"] - indent $ saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"] - ln - saysLn ["instance HoppyP.Ord ", hsTypeName, " where"] - indent $ saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"] - - -- Generate const_cast functions: - -- castFooToConst :: Foo -> FooConst - -- castFooToNonconst :: FooConst -> Foo - hsTypeNameOppConst <- toHsDataTypeName (constNegate cst) cls - ln - addExport constCastFnName - saysLn [constCastFnName, " :: ", hsTypeNameOppConst, " -> ", hsTypeName] - when doDecls $ do - addImports $ hsImport1 "Prelude" "($)" - hsCtorOppConst <- toHsDataCtorName Unmanaged (constNegate cst) cls - hsCtorGcOppConst <- toHsDataCtorName Managed (constNegate cst) cls - saysLn [constCastFnName, " (", hsCtorOppConst, - " ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"] - saysLn [constCastFnName, " (", hsCtorGcOppConst, - " fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"] - - -- Generate an instance of CppPtr. - ln - if doDecls - then do addImports $ hsImport1 "Prelude" "($)" - saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"] - indent $ do - saysLn ["nullptr = ", hsCtor, " HoppyF.nullPtr"] - ln - saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"] - saysLn ["withCppPtr (", hsCtorGc, - " fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"] - ln - saysLn ["toPtr (", hsCtor, " ptr') = ptr'"] - saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"] - ln - saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"] - saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"] - - when (classDtorIsPublic cls) $ do - addImports $ hsImport1 "Prelude" "(==)" - ln - saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"] - indent $ do - -- Note, similar "delete" and "toGc" functions are generated for exception - -- classes' ExceptionClassInfo structures. - case cst of - Const -> - saysLn ["delete (", hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, " ptr'"] - Nonconst -> do - constTypeName <- toHsDataTypeName Const cls - saysLn ["delete (",hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, - " $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", constTypeName, ")"] - saysLn ["delete (", hsCtorGc, - " _ _) = HoppyP.fail $ HoppyP.concat ", - "[\"Deletable.delete: Asked to delete a GC-managed \", ", - show hsTypeName, ", \" object.\"]"] - ln - saysLn ["toGc this'@(", hsCtor, " ptr') = ", - -- No sense in creating a ForeignPtr for a null pointer. - "if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ", - "(HoppyP.flip ", hsCtorGc, " ptr') $ ", - "HoppyF.newForeignPtr ", - -- The foreign delete function takes a const pointer; we cast it to - -- take a Ptr () to match up with the ForeignPtr () we're creating, - -- assuming that data pointers have the same representation. - "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls, - " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ", - "(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"] - saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"] - - forM_ (classFindCopyCtor cls) $ \copyCtor -> do - copyCtorName <- toHsCtorName cls copyCtor - ln - saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ", - case cst of - Nonconst -> hsTypeName - Const -> hsTypeNameOppConst, - " where copy = ", copyCtorName] - - else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName] - - when (classDtorIsPublic cls) $ - saysLn ["instance HoppyFHR.Deletable ", hsTypeName] - - forM_ (classFindCopyCtor cls) $ \_ -> - saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ", - case cst of - Nonconst -> hsTypeName - Const -> hsTypeNameOppConst] - - -- Generate instances for all superclasses' typeclasses. - genInstances hsTypeName [] cls - - where genInstances :: String -> [Class] -> Class -> Generator () - genInstances hsTypeName path ancestorCls = do - -- In this example Bar inherits from Foo. We are generating instances - -- either for BarConst or Bar, depending on 'cst'. - -- - -- BarConst's instances: - -- instance FooConstPtr BarConst where - -- toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr' - -- toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr' - -- - -- instance BarConstPtr BarConst where - -- toFooConst = id - -- - -- Bar's instances: - -- instance FooConstPtr Bar - -- toFooConst (Bar ptr') = - -- FooConst $ castBarToFoo $ castBarToConst ptr' - -- toFooConst (BarGc fptr' ptr') = - -- FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr' - -- - -- instance FooPtr Bar - -- toFoo (Bar ptr') = - -- Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' - -- toFoo (BarGc fptr' ptr') = - -- FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' - -- - -- instance BarConstPtr Bar - -- toBarConst (Bar ptr') = Bar $ castBarToConst ptr' - -- toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr' - -- - -- instance BarPtr Bar - -- toBar = id - -- - -- In all cases, we unwrap the pointer, maybe add const, maybe do an - -- upcast, maybe remove const, then rewrap the pointer. The identity - -- cases are where we just unwrap and wrap again. - - forM_ (case cst of - Const -> [Const] - Nonconst -> [Const, Nonconst]) $ \ancestorCst -> do - ln - ancestorPtrClassName <- toHsPtrClassName ancestorCst ancestorCls - saysLn ["instance ", ancestorPtrClassName, " ", hsTypeName, - if doDecls then " where" else ""] - when doDecls $ indent $ do - -- Unqualified, for Haskell instance methods. - let castMethodName = toHsCastMethodName' ancestorCst ancestorCls - if null path && cst == ancestorCst - then do addImports hsImportForPrelude - saysLn [castMethodName, " = HoppyP.id"] - else do let addConst = cst == Nonconst - removeConst = ancestorCst == Nonconst - when (addConst || removeConst) $ - addImports hsImportForForeign - forM_ ([minBound..] :: [Managed]) $ \managed -> do - ancestorCtor <- case managed of - Unmanaged -> (\x -> [x]) <$> - toHsDataCtorName Unmanaged ancestorCst ancestorCls - Managed -> (\x -> [x, " fptr'"]) <$> - toHsDataCtorName Managed ancestorCst ancestorCls - ptrPattern <- case managed of - Unmanaged -> (\x -> [x, " ptr'"]) <$> - toHsDataCtorName Unmanaged cst cls - Managed -> (\x -> [x, " fptr' ptr'"]) <$> - toHsDataCtorName Managed cst cls - saysLn . concat =<< sequence - [ return $ - [castMethodName, " ("] ++ ptrPattern ++ [") = "] ++ ancestorCtor - , if removeConst - then do ancestorConstType <- toHsDataTypeName Const ancestorCls - ancestorNonconstType <- toHsDataTypeName Nonconst ancestorCls - return [" $ (HoppyF.castPtr :: HoppyF.Ptr ", - ancestorConstType, " -> HoppyF.Ptr ", - ancestorNonconstType, ")"] - else return [] - , if not $ null path - then do addImports $ hsImport1 "Prelude" "($)" - castPrimitiveName <- toHsCastPrimitiveName cls cls ancestorCls - return [" $ ", castPrimitiveName] - else return [] - , if addConst - then do addImports $ hsImport1 "Prelude" "($)" - nonconstTypeName <- toHsDataTypeName Nonconst cls - constTypeName <- toHsDataTypeName Const cls - return [" $ (HoppyF.castPtr :: HoppyF.Ptr ", - nonconstTypeName, " -> HoppyF.Ptr ", - constTypeName, ")"] - else return [] - , return [" ptr'"] - ] - - forM_ (classSuperclasses ancestorCls) $ - genInstances hsTypeName $ - ancestorCls : path - -sayExportClassHsVars :: SayExportMode -> Class -> Generator () -sayExportClassHsVars mode cls = - forM_ (classVariables cls) $ sayExportClassVar mode cls - -sayExportClassHsCtors :: SayExportMode -> Class -> Generator () -sayExportClassHsCtors mode cls = - withErrorContext "generating constructors" $ - forM_ (classCtors cls) $ \ctor -> - (sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*> - pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls) <*> - ctorExceptionHandlers) ctor - -sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator () -sayExportClassHsSpecialFns mode cls = do - typeName <- toHsDataTypeName Nonconst cls - typeNameConst <- toHsDataTypeName Const cls - - -- Say the delete function. - withErrorContext "generating delete bindings" $ - case mode of - SayExportForeignImports -> when (classDtorIsPublic cls) $ do - addImports $ mconcat [hsImportForForeign, hsImportForPrelude] - saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ", - toHsClassDeleteFnName' cls, " :: HoppyF.Ptr ", - typeNameConst, " -> HoppyP.IO ()"] - saysLn ["foreign import ccall \"&", classDeleteFnCppName cls, "\" ", - toHsClassDeleteFnPtrName' cls, " :: HoppyF.FunPtr (HoppyF.Ptr ", - typeNameConst, " -> HoppyP.IO ())"] - -- The user interface to this is the generic 'delete' function, rendered - -- elsewhere. - SayExportDecls -> return () - SayExportBoot -> return () - - withErrorContext "generating pointer Assignable instance" $ - case mode of - SayExportForeignImports -> return () - SayExportDecls -> do - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForForeign, - hsImportForRuntime] - ln - saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", - typeName, " where"] - indent $ sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'" - SayExportBoot -> return () - - -- If the class has an assignment operator that takes its own type, then - -- generate an instance of Assignable. - withErrorContext "generating Assignable instance" $ do - let assignmentMethods = flip filter (classMethods cls) $ \m -> - methodApplicability m == MNormal && - (methodParams m == [objT cls] || methodParams m == [refT $ constT $ objT cls]) && - (case methodImpl m of - RealMethod name -> name == FnOp OpAssign - FnMethod name -> name == FnOp OpAssign) - withAssignmentMethod f = case assignmentMethods of - [] -> return () - [m] -> f m - _ -> - throwError $ concat - ["Can't determine an Assignable instance to generator for ", show cls, - " because it has multiple assignment operators ", show assignmentMethods] - when (mode == SayExportDecls) $ withAssignmentMethod $ \m -> do - addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude] - valueClassName <- toHsValueClassName cls - assignmentMethodName <- toHsMethodName cls m - ln - saysLn ["instance ", valueClassName, " a => HoppyFHR.Assignable ", typeName, " a where"] - indent $ - saysLn ["assign x' y' = ", assignmentMethodName, " x' y' >> HoppyP.return ()"] - - -- A pointer to an object pointer is decodable to an object pointer by peeking - -- at the value, so generate a Decodable instance. You are now a two-star - -- programmer. There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which - -- handles deeper levels. - withErrorContext "generating pointer Decodable instance" $ do - case mode of - SayExportForeignImports -> return () - - SayExportDecls -> do - addImports $ mconcat [hsImport1 "Prelude" "(.)", - hsImportForForeign, - hsImportForPrelude, - hsImportForRuntime] - ln - saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", - typeName, ")) ", typeName, " where"] - indent $ do - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - saysLn ["decode = HoppyP.fmap ", ctorName, " . HoppyF.peek"] - - SayExportBoot -> do - addImports $ mconcat [hsImportForForeign, hsImportForRuntime] - ln - -- TODO Encodable. - saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", typeName] - - -- Say Encodable and Decodable instances, if the class is encodable and - -- decodable. - withErrorContext "generating Encodable/Decodable instances" $ do - let conv = getClassHaskellConversion cls - forM_ (classHaskellConversionType conv) $ \hsTypeGen -> do - let hsTypeStrGen = hsTypeGen >>= \hsType -> return $ "(" ++ prettyPrint hsType ++ ")" - - case mode of - SayExportForeignImports -> return () - - SayExportDecls -> do - -- Say the Encodable instances. - forM_ (classHaskellConversionToCppFn conv) $ \toCppFnGen -> do - hsTypeStr <- hsTypeStrGen - addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] - castMethodName <- toHsCastMethodName Const cls - - ln - saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"] - indent $ do - sayLn "encode =" - indent toCppFnGen - ln - saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"] - indent $ - saysLn ["encode = HoppyP.fmap (", castMethodName, - ") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"] - - -- Say the Decodable instances. - forM_ (classHaskellConversionFromCppFn conv) $ \fromCppFnGen -> do - hsTypeStr <- hsTypeStrGen - addImports hsImportForRuntime - castMethodName <- toHsCastMethodName Const cls - - ln - saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"] - indent $ - saysLn ["decode = HoppyFHR.decode . ", castMethodName] - ln - saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"] - indent $ do - sayLn "decode =" - indent fromCppFnGen - - SayExportBoot -> do - -- Say the Encodable instances. - forM_ (classHaskellConversionToCppFn conv) $ \_ -> do - hsTypeStr <- hsTypeStrGen - addImports hsImportForRuntime - ln - saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"] - saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"] - - -- Say the Decodable instances. - forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do - hsTypeStr <- hsTypeStrGen - addImports hsImportForRuntime - ln - saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"] - saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"] - --- | Generates a non-const @CppException@ instance if the class is an exception --- class. -sayExportClassExceptionSupport :: Bool -> Class -> Generator () -sayExportClassExceptionSupport doDecls cls = - when (classIsException cls) $ - withErrorContext "generating exception support" $ do - typeName <- toHsDataTypeName Nonconst cls - typeNameConst <- toHsDataTypeName Const cls - - -- Generate a non-const CppException instance. - exceptionId <- getClassExceptionId cls - addImports hsImportForRuntime - ln - saysLn ["instance HoppyFHR.CppException ", typeName, - if doDecls then " where" else ""] - when doDecls $ indent $ do - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - ctorGcName <- toHsDataCtorName Managed Nonconst cls - addImports $ mconcat [hsImports "Prelude" ["($)", "(.)", "(=<<)"], - hsImportForForeign, - hsImportForMap, - hsImportForPrelude] - sayLn "cppExceptionInfo _ =" - indent $ do - saysLn ["HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ", - show $ getExceptionId exceptionId, ") ", show typeName, - " upcasts' delete' copy' toGc'"] - - -- Note, similar "delete" and "toGc" functions are generated for the class's - -- Deletable instance. - saysLn ["where delete' ptr' = ", toHsClassDeleteFnName' cls, - " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeNameConst, ")"] - - indentSpaces 6 $ do - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - ln - saysLn ["copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ", - ctorName, " . HoppyF.castPtr"] - - ln - saysLn ["toGc' ptr' = HoppyF.newForeignPtr ", - -- The foreign delete function takes a const pointer; we cast it to - -- take a Ptr () to match up with the ForeignPtr () we're creating, - -- assuming that data pointers have the same representation. - "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls, - " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ", - "ptr'"] - - sayLn "upcasts' = HoppyDM.fromList" - indent $ case classSuperclasses cls of - [] -> sayLn "[]" - _ -> do - let genCast :: Bool -> [Class] -> Class -> Generator () - genCast first path ancestorCls = - when (classIsException ancestorCls) $ do - let path' = ancestorCls : path - ancestorId <- getClassExceptionId ancestorCls - ancestorCastChain <- forM (zip path' $ drop 1 path') $ \(to, from) -> - -- We're upcasting, so 'from' is the subclass. - toHsCastPrimitiveName from from to - saysLn $ concat [ [if first then "[" else ",", - " ( HoppyFHR.ExceptionId ", - show $ getExceptionId ancestorId, - ", \\(e' :: HoppyF.Ptr ()) -> "] - , intersperse " $ " $ - "HoppyF.castPtr" : - ancestorCastChain ++ - ["HoppyF.castPtr e' :: HoppyF.Ptr ()"] - , [")"] - ] - forM_ (classSuperclasses ancestorCls) $ genCast False path' - - forM_ (zip (classSuperclasses cls) (True : repeat False)) $ - \(ancestorCls, first) -> genCast first [cls] ancestorCls - sayLn "]" - - ln - saysLn ["cppExceptionBuild fptr' ptr' = ", ctorGcName, - " fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"] - ln - saysLn ["cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ctorName, - " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"] - - -- Generate a const CppException instance that piggybacks off of the - -- non-const implementation. - ln - saysLn ["instance HoppyFHR.CppException ", typeNameConst, - if doDecls then " where" else ""] - when doDecls $ indent $ do - addImports $ mconcat [hsImport1 "Prelude" "(.)", - hsImportForPrelude] - constCastFnName <- toHsConstCastFnName Const cls - saysLn ["cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ", - typeName, ")"] - saysLn ["cppExceptionBuild = (", constCastFnName, - " .) . HoppyFHR.cppExceptionBuild"] - saysLn ["cppExceptionBuildToGc = HoppyP.fmap ", constCastFnName, - " . HoppyFHR.cppExceptionBuildToGc"] - - -- Generate a non-const CppThrowable instance. - ln - saysLn ["instance HoppyFHR.CppThrowable ", typeName, - if doDecls then " where" else ""] - when doDecls $ indent $ do - ctorName <- toHsDataCtorName Unmanaged Nonconst cls - ctorGcName <- toHsDataCtorName Managed Nonconst cls - addImports $ mconcat [hsImportForForeign, - hsImportForPrelude] - saysLn ["toSomeCppException this'@(", ctorName, " ptr') = HoppyFHR.SomeCppException ", - "(HoppyFHR.cppExceptionInfo this') HoppyP.Nothing (HoppyF.castPtr ptr')"] - saysLn ["toSomeCppException this'@(", ctorGcName, " fptr' ptr') = HoppyFHR.SomeCppException ", - "(HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') (HoppyF.castPtr ptr')"] - -sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator () -sayExportClassCastPrimitives mode cls = withErrorContext "generating cast primitives" $ do - clsType <- toHsDataTypeName Const cls - case mode of - SayExportForeignImports -> - forAncestors cls $ \super -> do - hsCastFnName <- toHsCastPrimitiveName cls cls super - hsDownCastFnName <- toHsCastPrimitiveName cls super cls - superType <- toHsDataTypeName Const super - addImports hsImportForForeign - addExport hsCastFnName - saysLn [ "foreign import ccall \"", classCastFnCppName cls super - , "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType - ] - unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do - addExport hsDownCastFnName - saysLn [ "foreign import ccall \"", classCastFnCppName super cls - , "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr ", clsType - ] - return True - - SayExportDecls -> - -- Generate a downcast typeclass and instances for all ancestor classes - -- for the current constness. These don't need to be in the boot file, - -- since they're not used by other generated bindings. - unless (classIsSubclassOfMonomorphic cls) $ - forM_ [minBound..] $ \cst -> do - downCastClassName <- toHsDownCastClassName cst cls - downCastMethodName <- toHsDownCastMethodName cst cls - typeName <- toHsDataTypeName cst cls - addExport' downCastClassName - ln - saysLn ["class ", downCastClassName, " a where"] - indent $ saysLn [downCastMethodName, " :: ", - prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $ - HsTyCon $ UnQual $ HsIdent typeName] - ln - forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of - True -> return False - False -> do - superTypeName <- toHsDataTypeName cst super - primitiveCastFn <- toHsCastPrimitiveName cls super cls - saysLn ["instance ", downCastClassName, " ", superTypeName, " where"] - - -- If Foo is a superclass of Bar: - -- - -- instance BarSuper Foo where - -- downToBar castFooToNonconst . downcast' . castFooToConst - -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' - -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' - -- - -- instance BarSuperConst FooConst where - -- downToBarConst = downcast' - -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' - -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' - - indent $ do - case cst of - Const -> saysLn [downCastMethodName, " = cast'"] - Nonconst -> do - addImports $ hsImport1 "Prelude" "(.)" - castClsToNonconst <- toHsConstCastFnName Nonconst cls - castSuperToConst <- toHsConstCastFnName Const super - saysLn [downCastMethodName, " = ", castClsToNonconst, " . cast' . ", - castSuperToConst] - indent $ do - sayLn "where" - indent $ do - clsCtorName <- toHsDataCtorName Unmanaged Const cls - clsCtorGcName <- toHsDataCtorName Managed Const cls - superCtorName <- toHsDataCtorName Unmanaged Const super - superCtorGcName <- toHsDataCtorName Managed Const super - saysLn ["cast' (", superCtorName, " ptr') = ", - clsCtorName, " $ ", primitiveCastFn, " ptr'"] - saysLn ["cast' (", superCtorGcName, " fptr' ptr') = ", - clsCtorGcName , " fptr' $ ", primitiveCastFn, " ptr'"] - return True - - SayExportBoot -> do - forAncestors cls $ \super -> do - hsCastFnName <- toHsCastPrimitiveName cls cls super - superType <- toHsDataTypeName Const super - addImports $ hsImportForForeign - addExport hsCastFnName - saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType] - return True - - where forAncestors :: Class -> (Class -> Generator Bool) -> Generator () - forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do - recur <- f super - when recur $ forAncestors super f - --- | Outputs the @ExceptionDb@ needed by all Haskell gateway functions that deal --- with exceptions. -sayExceptionSupport :: Bool -> Generator () -sayExceptionSupport doDecls = do - iface <- askInterface - addExport "exceptionDb'" - addImports hsImportForRuntime - ln - sayLn "exceptionDb' :: HoppyFHR.ExceptionDb" - when doDecls $ do - addImports $ mconcat [hsImport1 "Prelude" "($)", - hsImportForMap] - sayLn "exceptionDb' = HoppyFHR.ExceptionDb $ HoppyDM.fromList" - indent $ do - let classes = interfaceAllExceptionClasses iface - case classes of - [] -> sayLn "[]" - _ -> do - addImports hsImportForPrelude - forM_ (zip classes (True : repeat False)) $ \(cls, first) -> do - exceptionId <- - fromMaybeM (throwError $ "sayExceptionSupport: Internal error, " ++ show cls ++ - " has no exception ID.") $ - interfaceExceptionClassId iface cls - typeName <- toHsDataTypeName Nonconst cls - saysLn [if first then "[ (" else ", (", - "HoppyFHR.ExceptionId ", show $ getExceptionId exceptionId, - ", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ", - typeName, "))"] - sayLn "]" - --- | Implements special logic on top of 'cppTypeToHsTypeAndUse', that computes --- the Haskell __qualified__ type for a function, including typeclass --- constraints. -fnToHsTypeAndUse :: HsTypeSide - -> Purity - -> [Type] - -> Type - -> ExceptionHandlers - -> Generator HsQualType -fnToHsTypeAndUse side purity paramTypes returnType exceptionHandlers = do - let catches = not $ null $ exceptionHandlersList exceptionHandlers - - params <- mapM contextForParam $ - (if catches && side == HsCSide - then (++ [("excId", ptrT intT), ("excPtr", ptrT $ ptrT voidT)]) - else id) $ - zip (map toArgName [1..]) paramTypes - let context = mapMaybe fst params :: HsContext - hsParams = map snd params - - -- Determine the 'HsHsSide' return type for the function. Do the conversion - -- to a Haskell type, and wrap the result in 'IO' if the function is impure. - -- (HsCSide types always get wrapped in IO.) - hsReturnInitial <- cppTypeToHsTypeAndUse side returnType - hsReturnForPurity <- case (purity, side) of - (Pure, HsHsSide) -> return hsReturnInitial - _ -> do - addImports hsImportForPrelude - return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnInitial - - return $ HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams - - where contextForParam :: (String, Type) -> Generator (Maybe HsAsst, HsType) - contextForParam (s, t) = case t of - Internal_TBitspace b -> receiveBitspace s t b - Internal_TPtr (Internal_TObj cls) -> receivePtr s cls Nonconst - Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls - Internal_TRef (Internal_TObj cls) -> receivePtr s cls Nonconst - Internal_TRef (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls - Internal_TObj cls -> receiveValue s t cls - Internal_TConst t' -> contextForParam (s, t') - _ -> handoff side t - - -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass - -- constraints. - handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType) - handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t - - -- Receives a @IsFooBitspace a => a@. - receiveBitspace s t b = case side of - HsCSide -> handoff side t - HsHsSide -> do - bitspaceClassName <- toHsBitspaceClassName b - let t' = HsTyVar $ HsIdent s - return (Just (UnQual $ HsIdent bitspaceClassName, [t']), - t') - - -- Receives a @FooPtr this => this@. - receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType) - receivePtr s cls cst = case side of - HsHsSide -> do - ptrClassName <- toHsPtrClassName cst cls - let t' = HsTyVar $ HsIdent s - return (Just (UnQual $ HsIdent ptrClassName, [t']), - t') - HsCSide -> do - addImports $ hsImportForForeign - typeName <- toHsDataTypeName cst cls - return (Nothing, HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") $ - HsTyVar $ HsIdent typeName) - - -- Receives a @FooValue a => a@. - receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType) - receiveValue s t cls = case side of - HsCSide -> handoff side t - HsHsSide -> do - addImports hsImportForRuntime - valueClassName <- toHsValueClassName cls - let t' = HsTyVar $ HsIdent s - return (Just (UnQual $ HsIdent valueClassName, [t']), - t') - -getMethodEffectiveParams :: Class -> Method -> [Type] -getMethodEffectiveParams cls method = - (case methodImpl method of - RealMethod {} -> case methodApplicability method of - MNormal -> (ptrT (objT cls):) - MConst -> (ptrT (constT $ objT cls):) - MStatic -> id - FnMethod {} -> id) $ - methodParams method - -getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers -getEffectiveExceptionHandlers handlers = do - ifaceHandlers <- interfaceExceptionHandlers <$> askInterface - moduleHandlers <- getExceptionHandlers <$> askModule - -- Exception handlers declared lower in the hierarchy take precedence over - -- those higher in the hierarchy; ExceptionHandlers is a left-biased monoid. - return $ mconcat [handlers, moduleHandlers, ifaceHandlers] - -getEffectiveCallbackThrows :: Callback -> Generator Bool -getEffectiveCallbackThrows cb = case callbackThrows cb of - Just b -> return b - Nothing -> moduleCallbacksThrow <$> askModule >>= \case - Just b -> return b - Nothing -> interfaceCallbacksThrow <$> askInterface - -getClassExceptionId :: Class -> Generator ExceptionId -getClassExceptionId cls = do - iface <- askInterface - fromMaybeM (throwError $ concat - ["Internal error, exception class ", show cls, " doesn't have an exception ID"]) $ - interfaceExceptionClassId iface cls +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +{-# LANGUAGE CPP #-} + +-- | Internal portion of the Haskell code generator. +module Foreign.Hoppy.Generator.Language.Haskell.Internal ( + Generation, + generate, + generatedFiles, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), pure) +#endif +import Control.Arrow ((&&&)) +import Control.Monad (forM, when) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except (throwError) +#else +import Control.Monad.Error (throwError) +#endif +import Control.Monad.Trans (lift) +import Control.Monad.Writer (execWriterT, tell) +import Data.Foldable (forM_) +import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp) +import Data.List (intersperse) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat, mempty) +#endif +import qualified Data.Set as S +import Foreign.Hoppy.Generator.Common +import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Spec.Class (toHsDataTypeName) +import Foreign.Hoppy.Generator.Language.Haskell +import System.FilePath ((<.>), pathSeparator) + +-- | The in-memory result of generating Haskell code for an interface. +newtype Generation = Generation + { generatedFiles :: M.Map FilePath String + -- ^ A map from paths of generated files to the contents of those files. + -- The file paths are relative paths below the Haskell generation root. + } + +-- | Runs the C++ code generator against an interface. +generate :: Interface -> Either ErrorMsg Generation +generate iface = do + -- Build the partial generation of each module. + modPartials <- forM (M.elems $ interfaceModules iface) $ \m -> + (,) m <$> execGenerator iface m (generateSource m) + + -- Compute the strongly connected components. If there is a nontrivial SCC, + -- then there is a module import cycle that we'll have to break with hs-boot + -- files. + let partialsByHsName :: M.Map HsModuleName Partial + partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials + + sccInput :: [((Module, Partial), Partial, [Partial])] + sccInput = for modPartials $ \x@(_, p) -> + (x, p, + mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $ + M.keys $ getHsImportSet $ outputImports $ partialOutput p) + + sccs :: [SCC (Module, Partial)] + sccs = stronglyConnComp sccInput + + fileContents <- execWriterT $ forM_ sccs $ \case + AcyclicSCC (_, p) -> tell [finishPartial p "hs"] + CyclicSCC mps -> do + let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps + forM_ mps $ \(m, p) -> do + -- Create a boot partial. + pBoot <- lift $ execGenerator iface m (generateBootSource m) + + -- Change the source and boot partials so that all imports of modules in + -- this cycle are {-# SOURCE #-} imports. + let p' = setSourceImports cycleModNames p + pBoot' = setSourceImports cycleModNames pBoot + + -- Emit the completed partials. + tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"] + + return $ Generation $ M.fromList fileContents + + where finishPartial :: Partial -> String -> (FilePath, String) + finishPartial p fileExt = + (listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt, + prependExtensions $ renderPartial p) + + setSourceImports :: S.Set HsModuleName -> Partial -> Partial + setSourceImports modulesToSourceImport p = + let output = partialOutput p + imports = outputImports output + imports' = makeHsImportSet $ + M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $ + getHsImportSet imports + output' = output { outputImports = imports' } + in p { partialOutput = output' } + + setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs + setSourceImportIfIn modulesToSourceImport key specs = + if hsImportModule key `S.member` modulesToSourceImport + then specs { hsImportSource = True } + else specs + +prependExtensions :: String -> String +prependExtensions = (prependExtensionsPrefix ++) + +prependExtensionsPrefix :: String +prependExtensionsPrefix = + -- MultiParamTypeClasses is necessary for instances of Decodable and + -- Encodable. FlexibleContexts is needed for the type signature of the + -- function that wraps the actual callback function in callback creation + -- functions. + -- + -- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions + -- to and from String, which is really [Char]. + -- + -- UndecidableInstances is needed for instances of the form "SomeClassConstPtr + -- a => SomeClassValue a" (overlapping instances are used here too). + concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}\n"] + where extensions = + [ "FlexibleContexts" + , "FlexibleInstances" + , "ForeignFunctionInterface" + , "MonoLocalBinds" + , "MultiParamTypeClasses" + , "ScopedTypeVariables" + , "TypeSynonymInstances" + , "UndecidableInstances" + ] + +generateSource :: Module -> Generator () +generateSource m = do + forM_ (moduleExports m) $ sayExport SayExportForeignImports + forM_ (moduleExports m) $ sayExport SayExportDecls + + iface <- askInterface + when (interfaceExceptionSupportModule iface == Just m) $ + sayExceptionSupport True + + addendumHaskell $ getAddendum m + +generateBootSource :: Module -> Generator () +generateBootSource m = do + forM_ (moduleExports m) $ sayExport SayExportBoot + + iface <- askInterface + when (interfaceExceptionSupportModule iface == Just m) $ + sayExceptionSupport False + +sayExport :: SayExportMode -> Export -> Generator () +sayExport mode export = do + sayExportHaskell mode export + + when (mode == SayExportDecls) $ + addendumHaskell $ getAddendum export + +-- | Outputs the @ExceptionDb@ needed by all Haskell gateway functions that deal +-- with exceptions. +sayExceptionSupport :: Bool -> Generator () +sayExceptionSupport doDecls = do + iface <- askInterface + addExport "exceptionDb'" + addImports hsImportForRuntime + ln + sayLn "exceptionDb' :: HoppyFHR.ExceptionDb" + when doDecls $ do + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForMap] + sayLn "exceptionDb' = HoppyFHR.ExceptionDb $ HoppyDM.fromList" + indent $ do + let classes = interfaceAllExceptionClasses iface + case classes of + [] -> sayLn "[]" + _ -> do + addImports hsImportForPrelude + forM_ (zip classes (True : repeat False)) $ \(cls, first) -> do + exceptionId <- + fromMaybeM (throwError $ "sayExceptionSupport: Internal error, " ++ show cls ++ + " has no exception ID.") $ + interfaceExceptionClassId iface cls + typeName <- toHsDataTypeName Nonconst cls + saysLn [if first then "[ (" else ", (", + "HoppyFHR.ExceptionId ", show $ getExceptionId exceptionId, + ", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ", + typeName, "))"] + sayLn "]" diff --git a/src/Foreign/Hoppy/Generator/Main.hs b/src/Foreign/Hoppy/Generator/Main.hs --- a/src/Foreign/Hoppy/Generator/Main.hs +++ b/src/Foreign/Hoppy/Generator/Main.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -49,7 +49,9 @@ import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (fromMaybe) -import Foreign.Hoppy.Generator.Common (writeFileIfDifferent) +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 @@ -73,45 +75,81 @@ -- ^ Generates C++ wrappers for an interface in the given location. | GenHaskell FilePath -- ^ Generates Haskell bindings for an interface in the given location. + | 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. data AppState = AppState { appInterfaces :: Map String Interface - , appCurrentInterface :: 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 - , appCurrentInterface = head ifaces + , appCurrentInterfaceName = interfaceName $ head ifaces , appCaches = M.empty + , appKeepTempOutputsOnFailure = False } type Caches = Map String InterfaceCache data InterfaceCache = InterfaceCache - { cacheInterface :: Interface - , generatedCpp :: Maybe Cpp.Generation + { generatedCpp :: Maybe Cpp.Generation , generatedHaskell :: Maybe Haskell.Generation } -emptyCache :: Interface -> InterfaceCache -emptyCache iface = InterfaceCache iface Nothing Nothing +emptyCache :: InterfaceCache +emptyCache = InterfaceCache Nothing Nothing -getGeneratedCpp :: InterfaceCache -> IO (InterfaceCache, Either String Cpp.Generation) -getGeneratedCpp cache = case generatedCpp cache of - Just gen -> return (cache, Right gen) - _ -> case Cpp.generate $ cacheInterface cache of - l@(Left _) -> return (cache, l) - r@(Right gen) -> return (cache { generatedCpp = Just gen }, r) +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 :: InterfaceCache -> IO (InterfaceCache, Either String Haskell.Generation) -getGeneratedHaskell cache = case generatedHaskell cache of - Just gen -> return (cache, Right gen) - _ -> case Haskell.generate $ cacheInterface cache of - l@(Left _) -> return (cache, l) - r@(Right gen) -> return (cache { generatedHaskell = 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 + -- | This provides a simple @main@ function for a generator. Define your @main@ -- as: -- @@ -127,7 +165,7 @@ -- | This is a version of 'defaultMain' that accepts multiple interfaces. defaultMain' :: [Either String Interface] -> IO () defaultMain' interfaceResults = do - interfaces <- forM interfaceResults $ \interfaceResult -> case interfaceResult of + interfaces <- forM interfaceResults $ \case Left errorMsg -> do hPutStrLn stderr $ "Error initializing interface: " ++ errorMsg exitFailure @@ -183,6 +221,13 @@ , " --gen-cpp Generate C++ bindings in a directory." , " --gen-hs 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] @@ -198,7 +243,7 @@ "--interface: Interface '" ++ name ++ "' doesn't exist in this generator." _ <- exitFailure return state - Just iface -> return state { appCurrentInterface = iface } + Just _ -> return state { appCurrentInterfaceName = name } (SelectInterface name:) <$> processArgs stateVar rest "--list-interfaces":rest -> do @@ -259,6 +304,40 @@ 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 @@ -269,15 +348,20 @@ createDirectoryIfMissing True $ takeDirectory path writeFileIfDifferent path contents -withCurrentCache :: MVar AppState -> (InterfaceCache -> IO (InterfaceCache, a)) -> IO a +withCurrentCache :: + MVar AppState + -> (AppState -> Interface -> InterfaceCache -> IO (Interface, InterfaceCache, a)) + -> IO a withCurrentCache stateVar fn = modifyMVar stateVar $ \state -> do - let currentInterface = appCurrentInterface state - name = interfaceName currentInterface - (cache, result) <- fn $ - fromMaybe (emptyCache currentInterface) $ - M.lookup name $ - appCaches state - return (state { appCaches = M.insert name cache $ appCaches state }, result) + 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 diff --git a/src/Foreign/Hoppy/Generator/Override.hs b/src/Foreign/Hoppy/Generator/Override.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Override.hs @@ -0,0 +1,187 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Support for specifying overrides of values based on parameters. +-- +-- For example, an entity may have a name that you want to override on a +-- per-language basis. A single value like this may be represented as a +-- @'WithOverrides' Language Name@ value. Such a value will have a default +-- name, as well as zero or more overrides, keyed by @Language@. +-- +-- A 'MapWithOverrides' type is also provided for ease of overriding values +-- inside of a map. +module Foreign.Hoppy.Generator.Override ( + WithOverrides, + plain, + overridden, + unoverriddenValue, + overriddenValues, + MapWithOverrides, + plainMap, + mapWithOverrides, + addOverrideMap, + addOverrideMaps, + applyOverrideMaps, + insertMapOverride, + overriddenMapLookup, + ) where + +import qualified Data.Map as M +import Data.Maybe (fromMaybe) + +-- | Represents a default value of type @v@ with optional overrides keyed by +-- parameter type @p@. The type @p@ must have an 'Ord' instance. +data WithOverrides p v = WithOverrides + { unoverriddenValue :: v + -- ^ The default, unoverriden value for the 'WithOverrides'. Lookups on the + -- override will return this value a given parameter doesn't have an + -- override. + + , overriddenValues :: M.Map p v + -- ^ Any overridden values that have been added to the 'WithOverrides'. + } + +-- | Creates a 'WithOverrides' with the given default value @v@, and no +-- overridden values. +plain :: v -> WithOverrides p v +plain x = WithOverrides x M.empty + +-- | Creates a 'WithOverrides' with the given default value @v@, and overridden +-- values in the map. +overridden :: v -> M.Map p v -> WithOverrides p v +overridden = WithOverrides + +-- | Extracts a value, possibly overridden based on a parameter. +getOverride :: Ord p => p -> WithOverrides p v -> v +getOverride p o = + fromMaybe (unoverriddenValue o) $ M.lookup p $ overriddenValues o + +addOverride :: Ord p => p -> v -> WithOverrides p v -> WithOverrides p v +addOverride p v o = o { overriddenValues = M.insert p v $ overriddenValues o } + +-- | Represents a map from @k@ values to @v@ values, where each entry can be +-- overridden based on parameter @p@. A key is either present with a default +-- value and possibly some overridden values, or it is completely absent -- it +-- is not possible for a key to have overridden values but no default value. +newtype MapWithOverrides p k v = + MapWithOverrides { fromMapWithOverrides :: M.Map k (WithOverrides p v) } + +-- | Converts a plain map to a 'MapWithOverrides' without any overrides. +plainMap :: M.Map k v -> MapWithOverrides p k v +plainMap = MapWithOverrides . M.map plain + +-- | Direct constructor for 'MapWithOverrides'. +mapWithOverrides :: M.Map k (WithOverrides p v) -> MapWithOverrides p k v +mapWithOverrides = MapWithOverrides + +-- | Adds an override @v@ for key @k@ under parameter @p@ to a +-- 'MapWithOverrides'. +-- +-- It is an error for a parameter to override a key that is not present in the +-- defaults map. +insertMapOverride :: + (Ord p, Ord k, Show p, Show k) + => p + -> k + -> v + -> MapWithOverrides p k v + -> MapWithOverrides p k v +insertMapOverride p k v (MapWithOverrides m) = + -- We could do this whole operation as an 'alter' rather than a + -- 'lookup'/'adjust', but this way, if an insertion is invalid then we return + -- an error directly rather than hiding it inside the resulting structure. + case M.lookup k m of + Just _ -> MapWithOverrides $ M.adjust (addOverride p v) k m + Nothing -> + error $ "insertMapOverride: Can't add override for parameter " ++ show p ++ + " under key " ++ show k ++ " that has no default value." + +-- | Adds a collection of overrides @v@ for multiple keys @k@, all under a single +-- parameter @p@, to a 'MapWithOverrides'. +-- +-- It is an error for a parameter to override a key that is not present in the +-- defaults map. +addOverrideMap :: + (Ord p, Ord k, Show p, Show k) + => p + -> M.Map k v + -> MapWithOverrides p k v + -> MapWithOverrides p k v +addOverrideMap p pOverrides (MapWithOverrides m) = + MapWithOverrides $ + M.foldrWithKey (\k vOverride acc -> + M.alter (\kOverrides -> case kOverrides of + Just overrides -> + Just $ addOverride p vOverride overrides + Nothing -> + error $ "addOverrideMap: Parameter " ++ show p ++ + " supplies override for key " ++ show k ++ + " that is not in the map of unoverridden values.") + k + acc) + m + pOverrides + +-- | Adds overrides @v@ for multiple keys @k@ under multiple parameters @p@ to a +-- 'MapWithOverrides'. +-- +-- It is an error for a parameter to override a key that is not present in the +-- defaults map. +addOverrideMaps :: + (Ord p, Ord k, Show p, Show k) + => M.Map p (M.Map k v) + -> MapWithOverrides p k v + -> MapWithOverrides p k v +addOverrideMaps overrideMaps (MapWithOverrides m) = + MapWithOverrides $ + M.foldrWithKey (\p pOverrides -> + fromMapWithOverrides . addOverrideMap p pOverrides . MapWithOverrides) + m + overrideMaps + +-- | Constructs a 'MapWithOverrides' from a map of default values and a bunch of +-- parameter-specific maps overlaid on top of it. +-- +-- It is an error for a parameter to override a key that is not present in the +-- defaults map. +applyOverrideMaps :: + (Ord p, Ord k, Show p, Show k) + => M.Map p (M.Map k v) + -> M.Map k v + -> MapWithOverrides p k v +applyOverrideMaps overrideMaps baseMap = + MapWithOverrides $ + M.foldrWithKey (\p pOverrides acc -> + M.foldrWithKey (\k vOverride acc' -> + M.alter (\kOverrides -> case kOverrides of + Just overrides -> + Just $ addOverride p vOverride overrides + Nothing -> + error $ "applyOverrideMaps: Parameter " ++ show p ++ + " supplies override for key " ++ show k ++ + " that is not in the map of unoverridden values.") + k + acc') + acc + pOverrides) + (M.map plain baseMap) + overrideMaps + +-- | Looks up a value for @k@ in the given 'MapWithOverrides', with the +-- possibility that the value is overridden by the parameter @p@. +overriddenMapLookup :: (Ord p, Ord k) => p -> k -> MapWithOverrides p k v -> Maybe v +overriddenMapLookup p k (MapWithOverrides x) = getOverride p <$> M.lookup k x diff --git a/src/Foreign/Hoppy/Generator/Spec.hs b/src/Foreign/Hoppy/Generator/Spec.hs --- a/src/Foreign/Hoppy/Generator/Spec.hs +++ b/src/Foreign/Hoppy/Generator/Spec.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -24,9 +24,19 @@ module Foreign.Hoppy.Generator.Spec ( module Foreign.Hoppy.Generator.Spec.Base, module Foreign.Hoppy.Generator.Spec.Conversion, + module Foreign.Hoppy.Generator.Spec.Variable, + module Foreign.Hoppy.Generator.Spec.Enum, + module Foreign.Hoppy.Generator.Spec.Function, + module Foreign.Hoppy.Generator.Spec.Callback, + module Foreign.Hoppy.Generator.Spec.Class, module Foreign.Hoppy.Generator.Spec.ClassFeature, ) where import Foreign.Hoppy.Generator.Spec.Base +import Foreign.Hoppy.Generator.Spec.Callback +import Foreign.Hoppy.Generator.Spec.Class import Foreign.Hoppy.Generator.Spec.ClassFeature import Foreign.Hoppy.Generator.Spec.Conversion +import Foreign.Hoppy.Generator.Spec.Enum +import Foreign.Hoppy.Generator.Spec.Function +import Foreign.Hoppy.Generator.Spec.Variable diff --git a/src/Foreign/Hoppy/Generator/Spec/Base.hs b/src/Foreign/Hoppy/Generator/Spec/Base.hs --- a/src/Foreign/Hoppy/Generator/Spec/Base.hs +++ b/src/Foreign/Hoppy/Generator/Spec/Base.hs @@ -1,2518 +1,1836 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner --- --- 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 . - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - -module Foreign.Hoppy.Generator.Spec.Base ( - -- * Interfaces - Interface, - ErrorMsg, - InterfaceOptions (..), - defaultInterfaceOptions, - interface, - interface', - interfaceName, - interfaceModules, - interfaceNamesToModules, - interfaceHaskellModuleBase, - interfaceDefaultHaskellModuleBase, - interfaceAddHaskellModuleBase, - interfaceHaskellModuleImportNames, - interfaceExceptionHandlers, - interfaceCallbacksThrow, - interfaceSetCallbacksThrow, - interfaceExceptionClassId, - interfaceExceptionSupportModule, - interfaceSetExceptionSupportModule, - interfaceSetSharedPtr, - -- * C++ includes - Include, - includeStd, - includeLocal, - includeToString, - -- * Modules - Module, - moduleName, - moduleHppPath, - moduleCppPath, - moduleExports, - moduleReqs, - moduleExceptionHandlers, - moduleCallbacksThrow, - moduleSetCallbacksThrow, - moduleAddendum, - moduleHaskellName, - makeModule, - moduleModify, - moduleModify', - moduleSetHppPath, - moduleSetCppPath, - moduleAddExports, - moduleAddHaskellName, - -- * Requirements - Reqs, - reqsIncludes, - reqInclude, - HasReqs (..), - addReqs, - addReqIncludes, - -- * Names and exports - ExtName, - toExtName, - isValidExtName, - fromExtName, - HasExtNames (..), - getAllExtNames, - FnName (..), - IsFnName (..), - Operator (..), - OperatorType (..), - operatorPreferredExtName, - operatorPreferredExtName', - operatorType, - Export (..), - exportAddendum, - Identifier, - identifierParts, - IdPart, - idPartBase, - idPartArgs, - ident, ident', ident1, ident2, ident3, ident4, ident5, - identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T, - -- * Basic types - Type (..), - normalizeType, - stripConst, - -- ** Variables - Variable, makeVariable, varIdentifier, varExtName, varType, varReqs, - varIsConst, varGetterExtName, varSetterExtName, - -- ** Enums - CppEnum, makeEnum, enumIdentifier, enumExtName, enumValueNames, enumReqs, - enumValuePrefix, enumSetValuePrefix, - -- ** Bitspaces - Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum, - bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn, - bitspaceAddCppType, bitspaceReqs, - bitspaceValuePrefix, bitspaceSetValuePrefix, - -- ** Functions - Purity (..), - Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs, fnExceptionHandlers, - -- ** Classes - Class, makeClass, classIdentifier, classExtName, classSuperclasses, - classEntities, classAddEntities, classVariables, classCtors, classMethods, - classDtorIsPublic, classSetDtorPrivate, - classConversion, classReqs, classEntityPrefix, classSetEntityPrefix, - classIsMonomorphicSuperclass, classSetMonomorphicSuperclass, - classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic, - classIsException, classMakeException, - ClassEntity (..), - IsClassEntity (..), classEntityExtName, classEntityForeignName, classEntityForeignName', - ClassVariable, - makeClassVariable, makeClassVariable_, - mkClassVariable, mkClassVariable_, - mkStaticClassVariable, mkStaticClassVariable_, - classVarCName, classVarExtName, classVarType, classVarStatic, classVarGettable, - classVarGetterExtName, classVarGetterForeignName, - classVarSetterExtName, classVarSetterForeignName, - Ctor, makeCtor, makeCtor_, mkCtor, mkCtor_, ctorExtName, ctorParams, ctorExceptionHandlers, - Method, - MethodImpl (..), - MethodApplicability (..), - Constness (..), - constNegate, - Staticness (..), - makeMethod, makeMethod_, - makeFnMethod, makeFnMethod_, - mkMethod, mkMethod_, mkMethod', mkMethod'_, - mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_, - mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_, - Prop, -- The data constructor is private. - mkProp, mkProp_, - mkStaticProp, mkStaticProp_, - mkBoolIsProp, mkBoolIsProp_, - mkBoolHasProp, mkBoolHasProp_, - methodImpl, methodExtName, methodApplicability, methodPurity, methodParams, - methodReturn, methodExceptionHandlers, methodConst, methodStatic, - -- *** Conversion to and from foreign values - ClassConversion (..), - classConversionNone, - classModifyConversion, - classSetConversion, - ClassHaskellConversion (..), - classHaskellConversionNone, - classSetHaskellConversion, - -- ** Callbacks - Callback, makeCallback, - callbackExtName, callbackParams, callbackReturn, callbackThrows, callbackReqs, - callbackSetThrows, - -- * Exceptions - ExceptionId (..), - exceptionCatchAllId, - ExceptionHandler (..), - ExceptionHandlers (..), - HandlesExceptions (getExceptionHandlers), - handleExceptions, - -- * Addenda - Addendum (..), - HasAddendum (..), - addAddendumHaskell, - -- * Haskell imports - HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..), - hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports', - hsImportSetMakeSource, - -- * Internal to Hoppy - interfaceAllExceptionClasses, - interfaceSharedPtr, - classFindCopyCtor, - -- ** Haskell imports - makeHsImportSet, - getHsImportSet, - hsImportForBits, - hsImportForException, - hsImportForInt, - hsImportForWord, - hsImportForForeign, - hsImportForForeignC, - hsImportForMap, - hsImportForPrelude, - hsImportForRuntime, - hsImportForSystemPosixTypes, - hsImportForTypeable, - hsImportForUnsafeIO, - -- ** Error messages - objToHeapTWrongDirectionErrorMsg, - tToGcInvalidFormErrorMessage, - toGcTWrongDirectionErrorMsg, - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Arrow ((&&&)) -import Control.Monad (liftM2, unless) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except (MonadError, throwError) -#else -import Control.Monad.Error (MonadError, throwError) -#endif -import Control.Monad.State (MonadState, StateT, execStateT, get, modify) -import Data.Char (isAlpha, isAlphaNum, toUpper) -import Data.Function (on) -import Data.List (intercalate, intersperse) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid, mappend, mconcat, mempty) -#endif -import Data.Semigroup as Sem -import qualified Data.Set as S -import Foreign.Hoppy.Generator.Common -import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as Haskell -import Language.Haskell.Syntax (HsType) - --- | Indicates strings that are error messages. -type ErrorMsg = String - --- | A complete specification of a C++ API. Generators for different languages, --- including the binding generator for C++, use these to produce their output. --- --- 'Interface' does not have a 'HandlesExceptions' instance because --- 'modifyExceptionHandlers' does not work for it (handled exceptions cannot be --- modified after an 'Interface' is constructed). -data Interface = Interface - { interfaceName :: String - -- ^ The textual name of the interface. - , interfaceModules :: M.Map String Module - -- ^ All of the individual modules, by 'moduleName'. - , interfaceNamesToModules :: M.Map ExtName Module - -- ^ Maps each 'ExtName' exported by some module to the module that exports - -- the name. - , interfaceHaskellModuleBase' :: Maybe [String] - -- ^ See 'interfaceHaskellModuleBase'. - , interfaceHaskellModuleImportNames :: M.Map Module String - -- ^ Short qualified module import names that generated modules use to refer - -- to each other tersely. - , interfaceExceptionHandlers :: ExceptionHandlers - -- ^ Exceptions that all functions in the interface may throw. - , interfaceCallbacksThrow :: Bool - -- ^ Whether callbacks within the interface support throwing C++ exceptions - -- from Haskell into C++ during their execution. This may be overridden by - -- 'moduleCallbacksThrow' and 'callbackThrows'. - , interfaceExceptionNamesToIds :: M.Map ExtName ExceptionId - -- ^ Maps from external names of exception classes to their exception IDs. - , interfaceExceptionSupportModule :: Maybe Module - -- ^ When an interface uses C++ exceptions, then one module needs to - -- manually be selected to contain some interface-specific runtime support. - -- This is the selected module. - , interfaceSharedPtr :: (Reqs, String) - -- ^ The name of the @shared_ptr@ class to use, and the requirements to use - -- it. This defaults to using @std::shared_ptr@ from @@, but can be - -- changed if necessary via 'interfaceSetSharedPtr'. - } - -instance Show Interface where - show iface = concat [""] - --- | Optional parameters when constructing an 'Interface' with 'interface'. -data InterfaceOptions = InterfaceOptions - { interfaceOptionsExceptionHandlers :: ExceptionHandlers - } - --- | Options used by 'interface'. This contains no exception handlers. -defaultInterfaceOptions :: InterfaceOptions -defaultInterfaceOptions = InterfaceOptions mempty - --- | Constructs an 'Interface' from the required parts. Some validation is --- performed; if the resulting interface would be invalid, an error message is --- returned instead. --- --- This function passes 'defaultInterfaceOptions' to 'interface''. -interface :: String -- ^ 'interfaceName' - -> [Module] -- ^ 'interfaceModules' - -> Either ErrorMsg Interface -interface ifName modules = interface' ifName modules defaultInterfaceOptions - --- | Same as 'interface', but accepts some optional arguments. -interface' :: String -- ^ 'interfaceName' - -> [Module] -- ^ 'interfaceModules' - -> InterfaceOptions - -> Either ErrorMsg Interface -interface' ifName modules options = do - -- TODO Check for duplicate module names. - -- TODO Check for duplicate module file paths. - - -- Check for multiple modules exporting an ExtName. - let extNamesToModules :: M.Map ExtName [Module] - extNamesToModules = - M.unionsWith (++) $ - for modules $ \mod -> - let extNames = concatMap getAllExtNames $ M.elems $ moduleExports mod - in M.fromList $ zip extNames $ repeat [mod] - - extNamesInMultipleModules :: [(ExtName, [Module])] - extNamesInMultipleModules = - M.toList $ - M.filter (\modules -> case modules of - _:_:_ -> True - _ -> False) - extNamesToModules - - unless (null extNamesInMultipleModules) $ - Left $ unlines $ - "Some external name(s) are exported by multiple modules:" : - map (\(extName, modules) -> - concat $ "- " : show extName : ": " : intersperse ", " (map show modules)) - extNamesInMultipleModules - - let haskellModuleImportNames = - M.fromList $ - (\a b f -> zipWith f a b) modules [1..] $ - \mod index -> (mod, 'M' : show index) - - -- Generate a unique exception ID integer for each exception class. IDs 0 and - -- 1 are reserved. - let exceptionNamesToIds = - M.fromList $ - zip (map classExtName $ interfaceAllExceptionClasses' modules) - (map ExceptionId [exceptionFirstFreeId..]) - - return Interface - { interfaceName = ifName - , interfaceModules = M.fromList $ map (moduleName &&& id) modules - , interfaceNamesToModules = M.map (\[x] -> x) extNamesToModules - , interfaceHaskellModuleBase' = Nothing - , interfaceHaskellModuleImportNames = haskellModuleImportNames - , interfaceExceptionHandlers = interfaceOptionsExceptionHandlers options - , interfaceCallbacksThrow = False - , interfaceExceptionNamesToIds = exceptionNamesToIds - , interfaceExceptionSupportModule = Nothing - , interfaceSharedPtr = (reqInclude $ includeStd "memory", "std::shared_ptr") - } - --- | The name of the parent Haskell module under which a Haskell module will be --- generated for a Hoppy 'Module'. This is a list of Haskell module path --- components, in other words, @'Data.List.intercalate' "."@ on the list --- produces a Haskell module name. Defaults to --- 'interfaceDefaultHaskellModuleBase', and may be overridden with --- 'interfaceAddHaskellModuleBase'. -interfaceHaskellModuleBase :: Interface -> [String] -interfaceHaskellModuleBase = - fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase' - --- | The default Haskell module under which Hoppy modules will be generated. --- This is @Foreign.Hoppy.Generated@, that is: --- --- > ["Foreign", "Hoppy", "Generated"] -interfaceDefaultHaskellModuleBase :: [String] -interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"] - --- | Sets an interface to generate all of its modules under the given Haskell --- module prefix. See 'interfaceHaskellModuleBase'. -interfaceAddHaskellModuleBase :: [String] -> Interface -> Either String Interface -interfaceAddHaskellModuleBase modulePath iface = case interfaceHaskellModuleBase' iface of - Nothing -> Right iface { interfaceHaskellModuleBase' = Just modulePath } - Just existingPath -> - Left $ concat - [ "addInterfaceHaskellModuleBase: Trying to add Haskell module base " - , intercalate "." modulePath, " to ", show iface - , " which already has a module base ", intercalate "." existingPath - ] - --- | Returns the the exception ID for a class in an interface, if it has one --- (i.e. if it's been marked as an exception class with 'classMakeException'). -interfaceExceptionClassId :: Interface -> Class -> Maybe ExceptionId -interfaceExceptionClassId iface cls = - M.lookup (classExtName cls) $ interfaceExceptionNamesToIds iface - --- | Returns all of the exception classes in an interface. -interfaceAllExceptionClasses :: Interface -> [Class] -interfaceAllExceptionClasses = interfaceAllExceptionClasses' . M.elems . interfaceModules - -interfaceAllExceptionClasses' :: [Module] -> [Class] -interfaceAllExceptionClasses' modules = - flip concatMap modules $ \mod -> - catMaybes $ - for (M.elems $ moduleExports mod) $ \export -> case export of - ExportClass cls | classIsException cls -> Just cls - _ -> Nothing - --- | Changes 'callbackThrows' for all callbacks in an interface that don't have it --- set explicitly at the module or callback level. -interfaceSetCallbacksThrow :: Bool -> Interface -> Interface -interfaceSetCallbacksThrow b iface = iface { interfaceCallbacksThrow = b } - --- | Sets an interface's exception support module, for interfaces that use --- exceptions. -interfaceSetExceptionSupportModule :: Module -> Interface -> Interface -interfaceSetExceptionSupportModule mod iface = case interfaceExceptionSupportModule iface of - Nothing -> iface { interfaceExceptionSupportModule = Just mod } - Just existingMod -> - if mod == existingMod - then iface - else error $ "interfaceSetExceptionSupportModule: " ++ show iface ++ - " already has exception support module " ++ show existingMod ++ - ", trying to set " ++ show mod ++ "." - --- | Installs a custom @std::shared_ptr@ implementation for use by an interface. --- Hoppy uses shared pointers for generated callback code. This function is --- useful for building code with compilers that don't provide a conforming --- @std::shared_ptr@ implementation. --- --- @interfaceSetSharedPtr ident reqs iface@ modifies @iface@ to use as a --- @shared_ptr@ class the C++ identifier @ident@, which needs @reqs@ in order to --- be accessed. @ident@ should be the name of a template to which an arbitrary --- @\@ can be appended, for example @"std::shared_ptr"@. --- --- A @shared_ptr\@ implementation @foo@ must at least provide the following --- interface: --- --- > foo(); // Initialization with a null pointer. --- > foo(T*); // Initialization with a given pointer. --- > foo(const foo&); // Copy-construction. --- > T& operator*() const; // Dereferencing (when non-null). --- > T* operator->() const; // Dereferencing and invocation (when non-null). --- > explicit operator bool() const; // Is the target object null? -interfaceSetSharedPtr :: String -> Reqs -> Interface -> Interface -interfaceSetSharedPtr identifier reqs iface = - iface { interfaceSharedPtr = (reqs, identifier) } - --- | An @#include@ directive in a C++ file. -data Include = Include - { includeToString :: String - -- ^ Returns the complete @#include ...@ line for an include, including - -- trailing newline. - } deriving (Eq, Ord, Show) - --- | Creates an @#include \<...\>@ directive. -includeStd :: String -> Include -includeStd path = Include $ "#include <" ++ path ++ ">\n" - --- | Creates an @#include "..."@ directive. -includeLocal :: String -> Include -includeLocal path = Include $ "#include \"" ++ path ++ "\"\n" - --- | A portion of functionality in a C++ API. An 'Interface' is composed of --- multiple modules. A module will generate a single compilation unit --- containing bindings for all of the module's exports. The C++ code for a --- generated module will @#include@ everything necessary for what is written to --- the header and source files separately. You can declare include dependencies --- with e.g. 'addReqIncludes', either for individual exports or at the module --- level (via the @'HasReqs' 'Module'@ instance). Dependencies between modules --- are handled automatically, and circularity is supported to a certain extent. --- See the documentation for the individual language modules for further --- details. -data Module = Module - { moduleName :: String - -- ^ The module's name. A module name must identify a unique module within - -- an 'Interface'. - , moduleHppPath :: String - -- ^ A relative path under a C++ sources root to which the generator will - -- write a header file for the module's C++ bindings. - , moduleCppPath :: String - -- ^ A relative path under a C++ sources root to which the generator will - -- write a source file for the module's C++ bindings. - , moduleExports :: M.Map ExtName Export - -- ^ All of the exports in a module. - , moduleReqs :: Reqs - -- ^ Module-level requirements. - , moduleHaskellName :: Maybe [String] - -- ^ The generated Haskell module name, underneath the - -- 'interfaceHaskellModuleBase'. If absent (by default), the 'moduleName' - -- is used. May be modified with 'moduleAddHaskellName'. - , moduleExceptionHandlers :: ExceptionHandlers - -- ^ Exceptions that all functions in the module may throw. - , moduleCallbacksThrow :: Maybe Bool - -- ^ Whether callbacks exported from the module support exceptions being - -- thrown during their execution. When present, this overrides - -- 'interfaceCallbacksThrow'. This maybe overridden by 'callbackThrows'. - , moduleAddendum :: Addendum - -- ^ The module's addendum. - } - -instance Eq Module where - (==) = (==) `on` moduleName - -instance Ord Module where - compare = compare `on` moduleName - -instance Show Module where - show m = concat [""] - -instance HasReqs Module where - getReqs = moduleReqs - setReqs reqs m = m { moduleReqs = reqs } - -instance HasAddendum Module where - getAddendum = moduleAddendum - setAddendum addendum m = m { moduleAddendum = addendum } - -instance HandlesExceptions Module where - getExceptionHandlers = moduleExceptionHandlers - modifyExceptionHandlers f m = m { moduleExceptionHandlers = f $ moduleExceptionHandlers m } - --- | Creates an empty module, ready to be configured with 'moduleModify'. -makeModule :: String -- ^ 'moduleName' - -> String -- ^ 'moduleHppPath' - -> String -- ^ 'moduleCppPath' - -> Module -makeModule name hppPath cppPath = Module - { moduleName = name - , moduleHppPath = hppPath - , moduleCppPath = cppPath - , moduleExports = M.empty - , moduleReqs = mempty - , moduleHaskellName = Nothing - , moduleExceptionHandlers = mempty - , moduleCallbacksThrow = Nothing - , moduleAddendum = mempty - } - --- | Extends a module. To be used with the module state-monad actions in this --- package. -moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module -moduleModify = flip execStateT - --- | Same as 'moduleModify', but calls 'error' in the case of failure, which is --- okay in for a generator which would abort in this case anyway. -moduleModify' :: Module -> StateT Module (Either String) () -> Module -moduleModify' m action = case moduleModify m action of - Left errorMsg -> - error $ concat - ["moduleModify' failed to modify ", show m, ": ", errorMsg] - Right m' -> m' - --- | Replaces a module's 'moduleHppPath'. -moduleSetHppPath :: MonadState Module m => String -> m () -moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path } - --- | Replaces a module's 'moduleCppPath'. -moduleSetCppPath :: MonadState Module m => String -> m () -moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path } - --- | Adds exports to a module. An export must only be added to any module at --- most once, and must not be added to multiple modules. -moduleAddExports :: (MonadError String m, MonadState Module m) => [Export] -> m () -moduleAddExports exports = do - m <- get - let existingExports = moduleExports m - newExports = M.fromList $ map (getPrimaryExtName &&& id) exports - duplicateNames = (S.intersection `on` M.keysSet) existingExports newExports - if S.null duplicateNames - then modify $ \m -> m { moduleExports = existingExports `mappend` newExports } - else throwError $ concat - ["moduleAddExports: ", show m, " defines external names multiple times: ", - show duplicateNames] - --- | Changes a module's 'moduleHaskellName' from the default. This can only be --- called once on a module. -moduleAddHaskellName :: (MonadError String m, MonadState Module m) => [String] -> m () -moduleAddHaskellName name = do - m <- get - case moduleHaskellName m of - Nothing -> modify $ \m -> m { moduleHaskellName = Just name } - Just name' -> - throwError $ concat - ["moduleAddHaskellName: ", show m, " already has Haskell name ", - show name', "; trying to add name ", show name, "."] - --- | Changes 'callbackThrows' for all callbacks in a module that don't have it --- set explicitly. -moduleSetCallbacksThrow :: MonadState Module m => Maybe Bool -> m () -moduleSetCallbacksThrow b = modify $ \m -> m { moduleCallbacksThrow = b } - --- | A set of requirements of needed to use an identifier in C++ (function, --- type, etc.), via a set of 'Include's. The monoid instance has 'mempty' as an --- empty set of includes, and 'mappend' unions two include sets. -data Reqs = Reqs - { reqsIncludes :: S.Set Include - -- ^ The includes specified by a 'Reqs'. - } deriving (Show) - -instance Sem.Semigroup Reqs where - (<>) (Reqs incl) (Reqs incl') = Reqs $ mappend incl incl' - -instance Monoid Reqs where - mempty = Reqs mempty - - mappend = (<>) - - mconcat reqs = Reqs $ mconcat $ map reqsIncludes reqs - --- | Creates a 'Reqs' that contains the given include. -reqInclude :: Include -> Reqs -reqInclude include = mempty { reqsIncludes = S.singleton include } - --- | Contains the data types for bindings to C++ entities: 'Function', 'Class', --- etc. Use 'addReqs' or 'addReqIncludes' to specify requirements for these --- entities, e.g. header files that must be included in order to access the --- underlying entities that are being bound. - --- | C++ types that have requirements in order to use them in generated --- bindings. -class HasReqs a where - {-# MINIMAL getReqs, (setReqs | modifyReqs) #-} - - -- | Returns an object's requirements. - getReqs :: a -> Reqs - - -- | Replaces an object's requirements with new ones. - setReqs :: Reqs -> a -> a - setReqs = modifyReqs . const - - -- | Modifies an object's requirements. - modifyReqs :: (Reqs -> Reqs) -> a -> a - modifyReqs f x = setReqs (f $ getReqs x) x - --- | Adds to a object's requirements. -addReqs :: HasReqs a => Reqs -> a -> a -addReqs reqs = modifyReqs $ mappend reqs - --- | Adds a list of includes to the requirements of an object. -addReqIncludes :: HasReqs a => [Include] -> a -> a -addReqIncludes includes = - modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes } - --- | An external name is a string that generated bindings use to uniquely --- identify an object at runtime. An external name must start with an --- alphabetic character, and may only contain alphanumeric characters and @'_'@. --- You are free to use whatever naming style you like; case conversions will be --- performed automatically when required. Hoppy does make use of some --- conventions though, for example with 'Operator's and in the provided bindings --- for the C++ standard library. --- --- External names must be unique within an interface. They may not be reused --- between modules. This assumption is used for symbol naming in compiled --- shared objects and to freely import modules in Haskell bindings. -newtype ExtName = ExtName - { fromExtName :: String - -- ^ Returns the string an an 'ExtName' contains. - } deriving (Eq, Sem.Semigroup, Monoid, Ord) - -instance Show ExtName where - show extName = concat ["$\"", fromExtName extName, "\"$"] - --- | Creates an 'ExtName' that contains the given string, erroring if the string --- is an invalid 'ExtName'. -toExtName :: String -> ExtName -toExtName str = case str of - -- Keep this logic in sync with isValidExtName. - [] -> error "An ExtName cannot be empty." - _ -> if isValidExtName str - then ExtName str - else error $ - "An ExtName must start with a letter and only contain letters, numbers, and '_': " ++ - show str - --- | Returns true if the given string is represents a valid 'ExtName'. -isValidExtName :: String -> Bool -isValidExtName str = case str of - -- Keep this logic in sync with toExtName. - [] -> False - c:cs -> isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs - --- | Generates an 'ExtName' from an 'Identifier', if the given name is absent. -extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName -extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of - [] -> error "extNameOrIdentifier: Invalid empty identifier." - parts -> toExtName $ idPartBase $ last parts - --- | Generates an 'ExtName' from an @'FnName' 'Identifier'@, if the given name --- is absent. -extNameOrFnIdentifier :: FnName Identifier -> Maybe ExtName -> ExtName -extNameOrFnIdentifier name = - fromMaybe $ case name of - FnName identifier -> case identifierParts identifier of - [] -> error "extNameOrFnIdentifier: Empty idenfitier." - parts -> toExtName $ idPartBase $ last parts - FnOp op -> operatorPreferredExtName op - --- | Generates an 'ExtName' from a string, if the given name is absent. -extNameOrString :: String -> Maybe ExtName -> ExtName -extNameOrString str = fromMaybe $ toExtName str - --- | Types that have an external name, and also optionally have nested entities --- with external names as well. See 'getAllExtNames'. -class HasExtNames a where - -- | Returns the external name by which a given entity is referenced. - getPrimaryExtName :: a -> ExtName - - -- | Returns external names nested within the given entity. Does not include - -- the primary external name. - getNestedExtNames :: a -> [ExtName] - getNestedExtNames _ = [] - --- | Returns a list of all of the external names an entity contains. This --- combines both 'getPrimaryExtName' and 'getNestedExtNames'. -getAllExtNames :: HasExtNames a => a -> [ExtName] -getAllExtNames x = getPrimaryExtName x : getNestedExtNames x - --- | The C++ name of a function or method. -data FnName name = - FnName name - -- ^ A regular, \"alphanumeric\" name. The exact type depends on what kind of - -- object is being named. - | FnOp Operator - -- ^ An operator name. - deriving (Eq, Ord) - -instance Show name => Show (FnName name) where - show (FnName name) = concat [""] - show (FnOp op) = concat [""] - --- | Enables implementing automatic conversions to a @'FnName' t@. -class IsFnName t a where - toFnName :: a -> FnName t - -instance IsFnName t (FnName t) where - toFnName = id - -instance IsFnName t t where - toFnName = FnName - -instance IsFnName t Operator where - toFnName = FnOp - --- | Overloadable C++ operators. -data Operator = - OpCall -- ^ @x(...)@ - | OpComma -- ^ @x, y@ - | OpAssign -- ^ @x = y@ - | OpArray -- ^ @x[y]@ - | OpDeref -- ^ @*x@ - | OpAddress -- ^ @&x@ - | OpAdd -- ^ @x + y@ - | OpAddAssign -- ^ @x += y@ - | OpSubtract -- ^ @x - y@ - | OpSubtractAssign -- ^ @x -= y@ - | OpMultiply -- ^ @x * y@ - | OpMultiplyAssign -- ^ @x *= y@ - | OpDivide -- ^ @x / y@ - | OpDivideAssign -- ^ @x /= y@ - | OpModulo -- ^ @x % y@ - | OpModuloAssign -- ^ @x %= y@ - | OpPlus -- ^ @+x@ - | OpMinus -- ^ @-x@ - | OpIncPre -- ^ @++x@ - | OpIncPost -- ^ @x++@ - | OpDecPre -- ^ @--x@ - | OpDecPost -- ^ @x--@ - | OpEq -- ^ @x == y@ - | OpNe -- ^ @x != y@ - | OpLt -- ^ @x < y@ - | OpLe -- ^ @x <= y@ - | OpGt -- ^ @x > y@ - | OpGe -- ^ @x >= y@ - | OpNot -- ^ @!x@ - | OpAnd -- ^ @x && y@ - | OpOr -- ^ @x || y@ - | OpBitNot -- ^ @~x@ - | OpBitAnd -- ^ @x & y@ - | OpBitAndAssign -- ^ @x &= y@ - | OpBitOr -- ^ @x | y@ - | OpBitOrAssign -- ^ @x |= y@ - | OpBitXor -- ^ @x ^ y@ - | OpBitXorAssign -- ^ @x ^= y@ - | OpShl -- ^ @x << y@ - | OpShlAssign -- ^ @x <<= y@ - | OpShr -- ^ @x >> y@ - | OpShrAssign -- ^ @x >>= y@ - deriving (Bounded, Enum, Eq, Ord, Show) - --- | The arity and syntax of an operator. -data OperatorType = - UnaryPrefixOperator String -- ^ Prefix unary operators. Examples: @!x@, @*x@, @++x@. - | UnaryPostfixOperator String -- ^ Postfix unary operators. Examples: @x--, x++@. - | BinaryOperator String -- ^ Infix binary operators. Examples: @x * y@, @x >>= y@. - | CallOperator -- ^ @x(...)@ with arbitrary arity. - | ArrayOperator -- ^ @x[y]@, a binary operator with non-infix syntax. - -data OperatorInfo = OperatorInfo - { operatorPreferredExtName'' :: ExtName - , operatorType' :: OperatorType - } - -makeOperatorInfo :: String -> OperatorType -> OperatorInfo -makeOperatorInfo = OperatorInfo . toExtName - --- | Returns a conventional string to use for the 'ExtName' of an operator. -operatorPreferredExtName :: Operator -> ExtName -operatorPreferredExtName op = case M.lookup op operatorInfo of - Just info -> operatorPreferredExtName'' info - Nothing -> - error $ concat - ["operatorPreferredExtName: Internal error, missing info for operator ", show op, "."] - --- | Returns a conventional name for an operator, as with --- 'operatorPreferredExtName', but as a string. -operatorPreferredExtName' :: Operator -> String -operatorPreferredExtName' = fromExtName . operatorPreferredExtName - --- | Returns the type of an operator. -operatorType :: Operator -> OperatorType -operatorType op = case M.lookup op operatorInfo of - Just info -> operatorType' info - Nothing -> - error $ concat - ["operatorType: Internal error, missing info for operator ", show op, "."] - --- | Metadata for operators. --- --- TODO Test out this missing data. -operatorInfo :: M.Map Operator OperatorInfo -operatorInfo = - let input = - [ (OpCall, makeOperatorInfo "CALL" CallOperator) - , (OpComma, makeOperatorInfo "COMMA" $ BinaryOperator ",") - , (OpAssign, makeOperatorInfo "ASSIGN" $ BinaryOperator "=") - , (OpArray, makeOperatorInfo "ARRAY" ArrayOperator) - , (OpDeref, makeOperatorInfo "DEREF" $ UnaryPrefixOperator "*") - , (OpAddress, makeOperatorInfo "ADDRESS" $ UnaryPrefixOperator "&") - , (OpAdd, makeOperatorInfo "ADD" $ BinaryOperator "+") - , (OpAddAssign, makeOperatorInfo "ADDA" $ BinaryOperator "+=") - , (OpSubtract, makeOperatorInfo "SUB" $ BinaryOperator "-") - , (OpSubtractAssign, makeOperatorInfo "SUBA" $ BinaryOperator "-=") - , (OpMultiply, makeOperatorInfo "MUL" $ BinaryOperator "*") - , (OpMultiplyAssign, makeOperatorInfo "MULA" $ BinaryOperator "*=") - , (OpDivide, makeOperatorInfo "DIV" $ BinaryOperator "/") - , (OpDivideAssign, makeOperatorInfo "DIVA" $ BinaryOperator "/=") - , (OpModulo, makeOperatorInfo "MOD" $ BinaryOperator "%") - , (OpModuloAssign, makeOperatorInfo "MODA" $ BinaryOperator "%=") - , (OpPlus, makeOperatorInfo "PLUS" $ UnaryPrefixOperator "+") - , (OpMinus, makeOperatorInfo "NEG" $ UnaryPrefixOperator "-") - , (OpIncPre, makeOperatorInfo "INC" $ UnaryPrefixOperator "++") - , (OpIncPost, makeOperatorInfo "INCPOST" $ UnaryPostfixOperator "++") - , (OpDecPre, makeOperatorInfo "DEC" $ UnaryPrefixOperator "--") - , (OpDecPost, makeOperatorInfo "DECPOST" $ UnaryPostfixOperator "--") - , (OpEq, makeOperatorInfo "EQ" $ BinaryOperator "==") - , (OpNe, makeOperatorInfo "NE" $ BinaryOperator "!=") - , (OpLt, makeOperatorInfo "LT" $ BinaryOperator "<") - , (OpLe, makeOperatorInfo "LE" $ BinaryOperator "<=") - , (OpGt, makeOperatorInfo "GT" $ BinaryOperator ">") - , (OpGe, makeOperatorInfo "GE" $ BinaryOperator ">=") - , (OpNot, makeOperatorInfo "NOT" $ UnaryPrefixOperator "!") - , (OpAnd, makeOperatorInfo "AND" $ BinaryOperator "&&") - , (OpOr, makeOperatorInfo "OR" $ BinaryOperator "||") - , (OpBitNot, makeOperatorInfo "BNOT" $ UnaryPrefixOperator "~") - , (OpBitAnd, makeOperatorInfo "BAND" $ BinaryOperator "&") - , (OpBitAndAssign, makeOperatorInfo "BANDA" $ BinaryOperator "&=") - , (OpBitOr, makeOperatorInfo "BOR" $ BinaryOperator "|") - , (OpBitOrAssign, makeOperatorInfo "BORA" $ BinaryOperator "|=") - , (OpBitXor, makeOperatorInfo "BXOR" $ BinaryOperator "^") - , (OpBitXorAssign, makeOperatorInfo "BXORA" $ BinaryOperator "^=") - , (OpShl, makeOperatorInfo "SHL" $ BinaryOperator "<<") - , (OpShlAssign, makeOperatorInfo "SHLA" $ BinaryOperator "<<=") - , (OpShr, makeOperatorInfo "SHR" $ BinaryOperator ">>") - , (OpShrAssign, makeOperatorInfo "SHR" $ BinaryOperator ">>=") - ] - in if map fst input == [minBound..] - then M.fromList input - else error "operatorInfo: Operator info list is out of sync with Operator data type." - --- | Specifies some C++ object (function or class) to give access to. -data Export = - ExportVariable Variable -- ^ Exports a variable. - | ExportEnum CppEnum -- ^ Exports an enum. - | ExportBitspace Bitspace -- ^ Exports a bitspace. - | ExportFn Function -- ^ Exports a function. - | ExportClass Class -- ^ Exports a class with all of its contents. - | ExportCallback Callback -- ^ Exports a callback. - deriving (Show) - -instance HasExtNames Export where - getPrimaryExtName x = case x of - ExportVariable v -> getPrimaryExtName v - ExportEnum e -> getPrimaryExtName e - ExportBitspace b -> getPrimaryExtName b - ExportFn f -> getPrimaryExtName f - ExportClass cls -> getPrimaryExtName cls - ExportCallback cb -> getPrimaryExtName cb - - getNestedExtNames x = case x of - ExportVariable v -> getNestedExtNames v - ExportEnum e -> getNestedExtNames e - ExportBitspace b -> getNestedExtNames b - ExportFn f -> getNestedExtNames f - ExportClass cls -> getNestedExtNames cls - ExportCallback cb -> getNestedExtNames cb - --- | Returns the export's addendum. 'Export' doesn't have a 'HasAddendum' --- instance because you normally wouldn't want to modify the addendum of one. -exportAddendum export = case export of - ExportVariable v -> getAddendum v - ExportEnum e -> getAddendum e - ExportBitspace bs -> getAddendum bs - ExportFn f -> getAddendum f - ExportClass cls -> getAddendum cls - ExportCallback cb -> getAddendum cb - --- | A path to some C++ object, including namespaces. An identifier consists of --- multiple parts separated by @\"::\"@. Each part has a name string followed --- by an optional template argument list, where each argument gets rendered from --- a 'Type' (non-type arguments for template metaprogramming are not supported). -newtype Identifier = Identifier - { identifierParts :: [IdPart] - -- ^ The separate parts of the identifier, between @::@s. - } deriving (Eq) - -instance Show Identifier where - show ident = - (\words -> concat $ ""]) $ - intersperse "::" $ - map (\part -> case idPartArgs part of - Nothing -> idPartBase part - Just args -> - concat $ - idPartBase part : "<" : - intersperse ", " (map show args) ++ [">"]) $ - identifierParts ident - --- | A single component of an 'Identifier', between @::@s. -data IdPart = IdPart - { idPartBase :: String - -- ^ The name within the enclosing scope. - , idPartArgs :: Maybe [Type] - -- ^ Template arguments, if present. - } deriving (Eq, Show) - --- | Creates an identifier of the form @a@. -ident :: String -> Identifier -ident a = Identifier [IdPart a Nothing] - --- | Creates an identifier of the form @a1::a2::...::aN@. -ident' :: [String] -> Identifier -ident' = Identifier . map (\x -> IdPart x Nothing) - --- | Creates an identifier of the form @a::b@. -ident1 :: String -> String -> Identifier -ident1 a b = ident' [a, b] - --- | Creates an identifier of the form @a::b::c@. -ident2 :: String -> String -> String -> Identifier -ident2 a b c = ident' [a, b, c] - --- | Creates an identifier of the form @a::b::c::d@. -ident3 :: String -> String -> String -> String -> Identifier -ident3 a b c d = ident' [a, b, c, d] - --- | Creates an identifier of the form @a::b::c::d::e@. -ident4 :: String -> String -> String -> String -> String -> Identifier -ident4 a b c d e = ident' [a, b, c, d, e] - --- | Creates an identifier of the form @a::b::c::d::e::f@. -ident5 :: String -> String -> String -> String -> String -> String -> Identifier -ident5 a b c d e f = ident' [a, b, c, d, e, f] - --- | Creates an identifier of the form @a\<...\>@. -identT :: String -> [Type] -> Identifier -identT a ts = Identifier [IdPart a $ Just ts] - --- | Creates an identifier with arbitrary many templated and non-templated --- parts. -identT' :: [(String, Maybe [Type])] -> Identifier -identT' = Identifier . map (uncurry IdPart) - --- | Creates an identifier of the form @a::b\<...\>@. -ident1T :: String -> String -> [Type] -> Identifier -ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts] - --- | Creates an identifier of the form @a::b::c\<...\>@. -ident2T :: String -> String -> String -> [Type] -> Identifier -ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts] - --- | Creates an identifier of the form @a::b::c::d\<...\>@. -ident3T :: String -> String -> String -> String -> [Type] -> Identifier -ident3T a b c d ts = - Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, - IdPart d $ Just ts] - --- | Creates an identifier of the form @a::b::c::d::e\<...\>@. -ident4T :: String -> String -> String -> String -> String -> [Type] -> Identifier -ident4T a b c d e ts = - Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, - IdPart d Nothing, IdPart e $ Just ts] - --- | Creates an identifier of the form @a::b::c::d::e::f\<...\>@. -ident5T :: String -> String -> String -> String -> String -> String -> [Type] -> Identifier -ident5T a b c d e f ts = - Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, - IdPart d Nothing, IdPart e Nothing, IdPart f $ Just ts] - --- | A concrete C++ type. Use the bindings in "Foreign.Hoppy.Generator.Types" --- for values of this type; these data constructors are subject to change --- without notice. -data Type = - Internal_TVoid - | Internal_TBool - | Internal_TChar - | Internal_TUChar - | Internal_TShort - | Internal_TUShort - | Internal_TInt - | Internal_TUInt - | Internal_TLong - | Internal_TULong - | Internal_TLLong - | Internal_TULLong - | Internal_TFloat - | Internal_TDouble - | Internal_TInt8 - | Internal_TInt16 - | Internal_TInt32 - | Internal_TInt64 - | Internal_TWord8 - | Internal_TWord16 - | Internal_TWord32 - | Internal_TWord64 - | Internal_TPtrdiff - | Internal_TSize - | Internal_TSSize - | Internal_TEnum CppEnum - | Internal_TBitspace Bitspace - | Internal_TPtr Type - | Internal_TRef Type - | Internal_TFn [Type] Type - | Internal_TCallback Callback - | Internal_TObj Class - | Internal_TObjToHeap Class - | Internal_TToGc Type - | Internal_TConst Type - deriving (Eq, Show) - --- | Canonicalizes a 'Type' without changing its meaning. Multiple nested --- 'Internal_TConst's are collapsed into a single one. -normalizeType :: Type -> Type -normalizeType t = case t of - Internal_TVoid -> t - Internal_TBool -> t - Internal_TChar -> t - Internal_TUChar -> t - Internal_TShort -> t - Internal_TUShort -> t - Internal_TInt -> t - Internal_TUInt -> t - Internal_TLong -> t - Internal_TULong -> t - Internal_TLLong -> t - Internal_TULLong -> t - Internal_TFloat -> t - Internal_TDouble -> t - Internal_TInt8 -> t - Internal_TInt16 -> t - Internal_TInt32 -> t - Internal_TInt64 -> t - Internal_TWord8 -> t - Internal_TWord16 -> t - Internal_TWord32 -> t - Internal_TWord64 -> t - Internal_TPtrdiff -> t - Internal_TSize -> t - Internal_TSSize -> t - Internal_TEnum _ -> t - Internal_TBitspace _ -> t - Internal_TPtr t' -> Internal_TPtr $ normalizeType t' - Internal_TRef t' -> Internal_TRef $ normalizeType t' - Internal_TFn paramTypes retType -> - Internal_TFn (map normalizeType paramTypes) $ normalizeType retType - Internal_TCallback _ -> t - Internal_TObj _ -> t - Internal_TObjToHeap _ -> t - Internal_TToGc _ -> t - Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t' - Internal_TConst _ -> t - --- | Strips leading 'Internal_TConst's off of a type. -stripConst :: Type -> Type -stripConst t = case t of - Internal_TConst t' -> stripConst t' - _ -> t - --- | A C++ variable. --- --- Use this data type's 'HasReqs' instance to make the variable accessible. -data Variable = Variable - { varIdentifier :: Identifier - -- ^ The identifier used to refer to the variable. - , varExtName :: ExtName - -- ^ The variable's external name. - , varType :: Type - -- ^ The variable's type. This may be - -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is - -- read-only. - , varReqs :: Reqs - -- ^ Requirements for bindings to access this variable. - , varAddendum :: Addendum - -- ^ The variable's addendum. - } - -instance Eq Variable where - (==) = (==) `on` varExtName - -instance Show Variable where - show v = concat [""] - -instance HasExtNames Variable where - getPrimaryExtName = varExtName - getNestedExtNames v = [varGetterExtName v, varSetterExtName v] - -instance HasReqs Variable where - getReqs = varReqs - setReqs reqs v = v { varReqs = reqs } - -instance HasAddendum Variable where - getAddendum = varAddendum - setAddendum addendum v = v { varAddendum = addendum } - --- | Creates a binding for a C++ variable. -makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable -makeVariable identifier maybeExtName t = - Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty - --- | Returns whether the variable is constant, i.e. whether its type is --- @'Foreign.Hoppy.Generator.Types.constT' ...@. -varIsConst :: Variable -> Bool -varIsConst v = case varType v of - Internal_TConst _ -> True - _ -> False - --- | Returns the external name of the getter function for the variable. -varGetterExtName :: Variable -> ExtName -varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName - --- | Returns the external name of the setter function for the variable. -varSetterExtName :: Variable -> ExtName -varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName - --- | A C++ enum declaration. An enum should actually be enumerable (in the --- sense of Haskell's 'Enum'); if it's not, consider using a 'Bitspace' instead. -data CppEnum = CppEnum - { enumIdentifier :: Identifier - -- ^ The identifier used to refer to the enum. - , enumExtName :: ExtName - -- ^ The enum's external name. - , enumValueNames :: [(Int, [String])] - -- ^ The numeric values and names of the enum values. A single value's name - -- is broken up into words. How the words and ext name get combined to make - -- a name in a particular foreign language depends on the language. - , enumReqs :: Reqs - -- ^ Requirements for bindings to access this enum. Currently unused, but - -- will be in the future. - , enumAddendum :: Addendum - -- ^ The enum's addendum. - , enumValuePrefix :: String - -- ^ The prefix applied to value names ('enumValueNames') when determining - -- the names of values in foreign languages. This defaults to the external - -- name of the enum, plus an underscore. - -- - -- See 'enumSetValuePrefix'. - } - -instance Eq CppEnum where - (==) = (==) `on` enumExtName - -instance Show CppEnum where - show e = concat [""] - -instance HasExtNames CppEnum where - getPrimaryExtName = enumExtName - -instance HasReqs CppEnum where - getReqs = enumReqs - setReqs reqs e = e { enumReqs = reqs } - -instance HasAddendum CppEnum where - getAddendum = enumAddendum - setAddendum addendum e = e { enumAddendum = addendum } - --- | Creates a binding for a C++ enum. -makeEnum :: Identifier -- ^ 'enumIdentifier' - -> Maybe ExtName - -- ^ An optional external name; will be automatically derived from - -- the identifier if absent. - -> [(Int, [String])] -- ^ 'enumValueNames' - -> CppEnum -makeEnum identifier maybeExtName valueNames = - let extName = extNameOrIdentifier identifier maybeExtName - in CppEnum - identifier - extName - valueNames - mempty - mempty - (fromExtName extName ++ "_") - --- | Sets the prefix applied to the names of enum values' identifiers in foreign --- languages. --- --- See 'enumValuePrefix'. -enumSetValuePrefix :: String -> CppEnum -> CppEnum -enumSetValuePrefix prefix enum = enum { enumValuePrefix = prefix } - --- | A C++ numeric space with bitwise operations. This is similar to a --- 'CppEnum', but in addition to the extra operations, this differs in that --- these values aren't enumerable. --- --- Additionally, as a kludge for Qtah, a bitspace may have a C++ type --- ('bitspaceCppTypeIdentifier') separate from its numeric type --- ('bitspaceType'). Qt bitspaces aren't raw numbers but are instead type-safe --- @QFlags@ objects that don't implicitly convert from integers, so we need a --- means to do so manually. Barring general ad-hoc argument and return value --- conversion support, we allow this as follows: when given a C++ type, then a --- bitspace may also have a conversion function between the numeric and C++ --- type, in each direction. If a conversion function is present, it will be --- used for conversions in its respective direction. The C++ type is not a full --- 'Type', but only an 'Identifier', since additional information is not needed. --- See 'bitspaceAddCppType'. -data Bitspace = Bitspace - { bitspaceExtName :: ExtName - -- ^ The bitspace's external name. - , bitspaceType :: Type - -- ^ The C++ type used for bits values. This should be a primitive numeric - -- type, usually 'Foreign.Hoppy.Generator.Types.intT'. - , bitspaceValueNames :: [(Int, [String])] - -- ^ The numeric values and names of the bitspace values. See - -- 'enumValueNames'. - , bitspaceEnum :: Maybe CppEnum - -- ^ An associated enum, whose values may be converted to values in the - -- bitspace. - , bitspaceCppTypeIdentifier :: Maybe Identifier - -- ^ The optional C++ type for a bitspace. - , bitspaceToCppValueFn :: Maybe String - -- ^ The name of a C++ function to convert from 'bitspaceType' to the - -- bitspace's C++ type. - , bitspaceFromCppValueFn :: Maybe String - -- ^ The name of a C++ function to convert from the bitspace's C++ type to - -- 'bitspaceType'. - , bitspaceReqs :: Reqs - -- ^ Requirements for emitting the bindings for a bitspace, i.e. what's - -- necessary to reference 'bitspaceCppTypeIdentifier', - -- 'bitspaceFromCppValueFn', and 'bitspaceToCppValueFn'. 'bitspaceType' can - -- take some numeric types that require includes as well, but you don't need - -- to list these here. - , bitspaceAddendum :: Addendum - -- ^ The bitspace's addendum. - , bitspaceValuePrefix :: String - -- ^ The prefix applied to value names ('bitspaceValueNames') when - -- determining the names of values in foreign languages. This defaults to - -- the external name of the bitspace, plus an underscore. - -- - -- See 'bitspaceSetValuePrefix'. - } - -instance Eq Bitspace where - (==) = (==) `on` bitspaceExtName - -instance Show Bitspace where - show e = concat [""] - -instance HasExtNames Bitspace where - getPrimaryExtName = bitspaceExtName - -instance HasReqs Bitspace where - getReqs = bitspaceReqs - setReqs reqs b = b { bitspaceReqs = reqs } - -instance HasAddendum Bitspace where - getAddendum = bitspaceAddendum - setAddendum addendum bs = bs { bitspaceAddendum = addendum } - --- | Creates a binding for a C++ bitspace. -makeBitspace :: ExtName -- ^ 'bitspaceExtName' - -> Type -- ^ 'bitspaceType' - -> [(Int, [String])] -- ^ 'bitspaceValueNames' - -> Bitspace -makeBitspace extName t valueNames = - Bitspace extName t valueNames Nothing Nothing Nothing Nothing mempty mempty - (fromExtName extName ++ "_") - --- | Sets the prefix applied to the names of enum values' identifiers in foreign --- languages. --- --- See 'enumValuePrefix'. -bitspaceSetValuePrefix :: String -> Bitspace -> Bitspace -bitspaceSetValuePrefix prefix bitspace = bitspace { bitspaceValuePrefix = prefix } - --- | Associates an enum with the bitspace. See 'bitspaceEnum'. -bitspaceAddEnum :: CppEnum -> Bitspace -> Bitspace -bitspaceAddEnum enum bitspace = case bitspaceEnum bitspace of - Just enum' -> - error $ concat - ["bitspaceAddEnum: Adding ", show enum, " to ", show bitspace, - ", but it already has ", show enum', "."] - Nothing -> - if bitspaceValueNames bitspace /= enumValueNames enum - then error $ concat - ["bitspaceAddEnum: Trying to add ", show enum, " to ", show bitspace, - ", but the values aren't equal.\nBitspace values: ", show $ bitspaceValueNames bitspace, - "\n Enum values: ", show $ enumValueNames enum] - else bitspace { bitspaceEnum = Just enum } - --- | @bitspaceAddCppType cppTypeIdentifier toCppValueFn fromCppValueFn@ --- associates a C++ type (plus optional conversion functions) with a bitspace. --- At least one conversion should be specified, otherwise adding the C++ type --- will mean nothing. You should also add use requirements to the bitspace for --- all of these arguments; see 'HasReqs'. -bitspaceAddCppType :: Identifier -> Maybe String -> Maybe String -> Bitspace -> Bitspace -bitspaceAddCppType cppTypeId toCppValueFnMaybe fromCppValueFnMaybe b = - case bitspaceCppTypeIdentifier b of - Just cppTypeId' -> - error $ concat - ["bitspaceAddCppType: Adding C++ type ", show cppTypeId, - " to ", show b, ", but it already has ", show cppTypeId', "."] - Nothing -> - b { bitspaceCppTypeIdentifier = Just cppTypeId - , bitspaceToCppValueFn = toCppValueFnMaybe - , bitspaceFromCppValueFn = fromCppValueFnMaybe - } - --- | Whether or not a function may cause side-effects. --- --- Haskell bindings for pure functions will not be in 'IO', and calls to pure --- functions will be executed non-strictly. Calls to impure functions will --- execute in the IO monad. --- --- Member functions for mutable classes should not be made pure, because it is --- difficult in general to control when the call will be made. -data Purity = Nonpure -- ^ Side-affects are possible. - | Pure -- ^ Side-affects will not happen. - deriving (Eq, Show) - --- | A C++ function declaration. --- --- Use this data type's 'HasReqs' instance to make the function accessible. You --- do not need to add requirements for parameter or return types. -data Function = Function - { fnCName :: FnName Identifier - -- ^ The identifier used to call the function. - , fnExtName :: ExtName - -- ^ The function's external name. - , fnPurity :: Purity - -- ^ Whether the function is pure. - , fnParams :: [Type] - -- ^ The function's parameter types. - , fnReturn :: Type - -- ^ The function's return type. - , fnReqs :: Reqs - -- ^ Requirements for bindings to access this function. - , fnExceptionHandlers :: ExceptionHandlers - -- ^ Exceptions that the function might throw. - , fnAddendum :: Addendum - -- ^ The function's addendum. - } - -instance Show Function where - show fn = - concat [""] - -instance HasExtNames Function where - getPrimaryExtName = fnExtName - -instance HasReqs Function where - getReqs = fnReqs - setReqs reqs fn = fn { fnReqs = reqs } - -instance HandlesExceptions Function where - getExceptionHandlers = fnExceptionHandlers - modifyExceptionHandlers f fn = fn { fnExceptionHandlers = f $ fnExceptionHandlers fn } - -instance HasAddendum Function where - getAddendum = fnAddendum - setAddendum addendum fn = fn { fnAddendum = addendum } - --- | Creates a binding for a C++ function. -makeFn :: IsFnName Identifier name - => name - -> Maybe ExtName - -- ^ An optional external name; will be automatically derived from - -- the identifier if absent. - -> Purity - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> Function -makeFn cName maybeExtName purity paramTypes retType = - let fnName = toFnName cName - in Function fnName - (extNameOrFnIdentifier fnName maybeExtName) - purity paramTypes retType mempty mempty mempty - --- | A C++ class declaration. See 'IsClassEntity' for more information about the --- interaction between a class's names and the names of entities within the --- class. --- --- Use this data type's 'HasReqs' instance to make the class accessible. You do --- not need to add requirements for methods' parameter or return types. -data Class = Class - { classIdentifier :: Identifier - -- ^ The identifier used to refer to the class. - , classExtName :: ExtName - -- ^ The class's external name. - , classSuperclasses :: [Class] - -- ^ The class's public superclasses. - , classEntities :: [ClassEntity] - -- ^ The class's entities. - , classDtorIsPublic :: Bool - -- ^ The class's methods. - , classConversion :: ClassConversion - -- ^ Behaviour for converting objects to and from foriegn values. - , classReqs :: Reqs - -- ^ Requirements for bindings to access this class. - , classAddendum :: Addendum - -- ^ The class's addendum. - , classIsMonomorphicSuperclass :: Bool - -- ^ This is true for classes passed through - -- 'classSetMonomorphicSuperclass'. - , classIsSubclassOfMonomorphic :: Bool - -- ^ This is true for classes passed through - -- 'classSetSubclassOfMonomorphic'. - , classIsException :: Bool - -- ^ Whether to support using the class as a C++ exception. - , classEntityPrefix :: String - -- ^ The prefix applied to the external names of entities (methods, etc.) - -- within this class when determining the names of foreign languages' - -- corresponding bindings. This defaults to the external name of the class, - -- plus an underscore. Changing this allows you to potentially have - -- entities with the same foreign name in separate modules. This may be the - -- empty string, in which case the foreign name will simply be the external - -- name of the entity. - -- - -- This does __not__ affect the things' external names themselves; external - -- names must still be unique in an interface. For instance, a method with - -- external name @bar@ in a class with external name @Flab@ and prefix - -- @Flob_@ will use the effective external name @Flab_bar@, but the - -- generated name in say Haskell would be @Flob_bar@. - -- - -- See 'IsClassEntity' and 'classSetEntityPrefix'. - } - -instance Eq Class where - (==) = (==) `on` classExtName - -instance Ord Class where - compare = compare `on` classExtName - -instance Show Class where - show cls = - concat [""] - -instance HasExtNames Class where - getPrimaryExtName = classExtName - - getNestedExtNames cls = concatMap (classEntityExtNames cls) $ classEntities cls - -instance HasReqs Class where - getReqs = classReqs - setReqs reqs cls = cls { classReqs = reqs } - -instance HasAddendum Class where - getAddendum = classAddendum - setAddendum addendum cls = cls { classAddendum = addendum } - --- | Creates a binding for a C++ class and its contents. -makeClass :: Identifier - -> Maybe ExtName - -- ^ An optional external name; will be automatically derived from the - -- identifier if absent by dropping leading namespaces, and taking the - -- last component (sans template arguments). - -> [Class] -- ^ Superclasses. - -> [ClassEntity] - -> Class -makeClass identifier maybeExtName supers entities = - let extName = extNameOrIdentifier identifier maybeExtName - in Class - { classIdentifier = identifier - , classExtName = extName - , classSuperclasses = supers - , classEntities = entities - , classDtorIsPublic = True - , classConversion = classConversionNone - , classReqs = mempty - , classAddendum = mempty - , classIsMonomorphicSuperclass = False - , classIsSubclassOfMonomorphic = False - , classIsException = False - , classEntityPrefix = fromExtName extName ++ "_" - } - --- | Sets the prefix applied to foreign languages' entities generated from --- methods, etc. within the class. --- --- See 'IsClassEntity' and 'classEntityPrefix'. -classSetEntityPrefix :: String -> Class -> Class -classSetEntityPrefix prefix cls = cls { classEntityPrefix = prefix } - --- | Adds constructors to a class. -classAddEntities :: [ClassEntity] -> Class -> Class -classAddEntities ents cls = - if null ents then cls else cls { classEntities = classEntities cls ++ ents } - --- | Returns all of the class's variables. -classVariables :: Class -> [ClassVariable] -classVariables = mapMaybe pickVar . classEntities - where pickVar ent = case ent of - CEVar v -> Just v - CECtor _ -> Nothing - CEMethod _ -> Nothing - CEProp _ -> Nothing - --- | Returns all of the class's constructors. -classCtors :: Class -> [Ctor] -classCtors = mapMaybe pickCtor . classEntities - where pickCtor ent = case ent of - CEVar _ -> Nothing - CECtor ctor -> Just ctor - CEMethod _ -> Nothing - CEProp _ -> Nothing - --- | Returns all of the class's methods, including methods generated from --- 'Prop's. -classMethods :: Class -> [Method] -classMethods = concatMap pickMethods . classEntities - where pickMethods ent = case ent of - CEVar _ -> [] - CECtor _ -> [] - CEMethod m -> [m] - CEProp (Prop ms) -> ms - --- | Marks a class's destructor as private, so that a binding for it won't be --- generated. -classSetDtorPrivate :: Class -> Class -classSetDtorPrivate cls = cls { classDtorIsPublic = False } - --- | Explicitly marks a class as being monomorphic (i.e. not having any --- virtual methods or destructors). By default, Hoppy assumes that a class that --- is derived is also polymorphic, but it can happen that this is not the case. --- Downcasting with @dynamic_cast@ from such classes is not available. See also --- 'classSetSubclassOfMonomorphic'. -classSetMonomorphicSuperclass :: Class -> Class -classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True } - --- | Marks a class as being derived from some monomorphic superclass. This --- prevents any downcasting to this class. Generally it is better to use --- 'classSetMonomorphicSuperclass' on the specific superclasses that are --- monomorphic, but in cases where this is not possible, this function can be --- applied to the subclass instead. -classSetSubclassOfMonomorphic :: Class -> Class -classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True } - --- | Marks a class as being used as an exception. This makes the class --- throwable and catchable. -classMakeException :: Class -> Class -classMakeException cls = case classIsException cls of - False -> cls { classIsException = True } - True -> cls - --- | Separately from passing object handles between C++ and foreign languages, --- objects can also be made to implicitly convert to native values in foreign --- languages. A single such type may be associated with any C++ class for each --- foreign language. The foreign type and the conversion process in each --- direction are specified using this object. Converting a C++ object to a --- foreign value is also called decoding, and vice versa is called encoding. A --- class may be convertible in one direction and not the other. --- --- To use these implicit conversions, instead of specifying an object handle --- type such as --- @'Foreign.Hoppy.Generator.Types.ptrT' . 'Foreign.Hoppy.Generator.Types.objT'@ --- or --- @'Foreign.Hoppy.Generator.Types.refT' . 'Foreign.Hoppy.Generator.Types.objT'@, --- use 'Foreign.Hoppy.Generator.Types.objT' directly. --- --- The subfields in this object specify how to do conversions between C++ and --- foreign languages. -data ClassConversion = ClassConversion - { classHaskellConversion :: ClassHaskellConversion - -- ^ Conversions to and from Haskell. - - -- NOTE! When adding new languages here, add the language to - -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the - -- language supports garbage collection. - } - --- | Conversion behaviour for a class that is not convertible. -classConversionNone :: ClassConversion -classConversionNone = ClassConversion classHaskellConversionNone - --- | Modifies a class's 'ClassConversion' structure with a given function. -classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class -classModifyConversion f cls = - let cls' = cls { classConversion = f $ classConversion cls } - conv = classConversion cls' - haskellConv = classHaskellConversion conv - in case undefined of - _ | (isJust (classHaskellConversionToCppFn haskellConv) || - isJust (classHaskellConversionFromCppFn haskellConv)) && - isNothing (classHaskellConversionType haskellConv) -> - error $ "classModifyConversion: " ++ show cls' ++ - " was given a Haskell-to-C++ or C++-to-Haskell conversion function" ++ - " but no Haskell type. Please provide a classHaskellConversionType." - _ -> cls' - --- | Replaces a class's 'ClassConversion' structure. -classSetConversion :: ClassConversion -> Class -> Class -classSetConversion c = classModifyConversion $ const c - --- | Controls how conversions between C++ objects and Haskell values happen in --- Haskell bindings. -data ClassHaskellConversion = ClassHaskellConversion - { classHaskellConversionType :: Maybe (Haskell.Generator HsType) - -- ^ Produces the Haskell type that represents a value of the corresponding - -- C++ class. This generator may add imports, but must not output code or - -- add exports. - , classHaskellConversionToCppFn :: Maybe (Haskell.Generator ()) - -- ^ Produces a Haskell expression that evaluates to a function that takes - -- an value of the type that 'classHaskellConversionType' generates, and - -- returns a non-const handle for a new C++ object in IO. The generator - -- must output code and may add imports, but must not add exports. - -- - -- If this field is present, then 'classHaskellConversionType' must also be - -- present. - , classHaskellConversionFromCppFn :: Maybe (Haskell.Generator ()) - -- ^ Produces a Haskell expression that evaluates to a function that takes a - -- const handle for a C++ object, and returns a value of the type that - -- 'classHaskellConversionType' generates, in IO. It should not delete the - -- handle. The generator must output code and may add imports, but must not - -- add exports. - -- - -- If this field is present, then 'classHaskellConversionType' must also be - -- present. - } - --- | Conversion behaviour for a class that is not convertible to or from --- Haskell. -classHaskellConversionNone :: ClassHaskellConversion -classHaskellConversionNone = - ClassHaskellConversion - { classHaskellConversionType = Nothing - , classHaskellConversionToCppFn = Nothing - , classHaskellConversionFromCppFn = Nothing - } - --- | Replaces a class's 'classHaskellConversion' with a given value. -classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class -classSetHaskellConversion conv = classModifyConversion $ \c -> - c { classHaskellConversion = conv } - --- | Things that live inside of a class, and have the class's external name --- prepended to their own in generated code. With an external name of @\"bar\"@ --- and a class with external name @\"foo\"@, the resulting name will be --- @\"foo_bar\"@. --- --- See 'classEntityPrefix' and 'classSetEntityPrefix'. -class IsClassEntity a where - -- | Extracts the external name of the object, without the class name added. - classEntityExtNameSuffix :: a -> ExtName - --- | Computes the external name to use in generated code, containing both the --- class's and object's external names. This is the concatenation of the --- class's and entity's external names, separated by an underscore. -classEntityExtName :: IsClassEntity a => Class -> a -> ExtName -classEntityExtName cls x = - toExtName $ fromExtName (classExtName cls) ++ "_" ++ fromExtName (classEntityExtNameSuffix x) - --- | Computes the name under which a class entity is to be exposed in foreign --- languages. This is the concatenation of a class's entity prefix, and the --- external name of the entity. -classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName -classEntityForeignName cls x = - classEntityForeignName' cls $ classEntityExtNameSuffix x - --- | Computes the name under which a class entity is to be exposed in foreign --- languages, given a class and an entity's external name. The result is the --- concatenation of a class's entity prefix, and the external name of the --- entity. -classEntityForeignName' :: Class -> ExtName -> ExtName -classEntityForeignName' cls extName = - toExtName $ classEntityPrefix cls ++ fromExtName extName - --- | A C++ entity that belongs to a class. -data ClassEntity = - CEVar ClassVariable - | CECtor Ctor - | CEMethod Method - | CEProp Prop - --- | Returns all of the names in a 'ClassEntity' within the corresponding --- 'Class'. -classEntityExtNames :: Class -> ClassEntity -> [ExtName] -classEntityExtNames cls ent = case ent of - CEVar v -> [classEntityExtName cls v] - CECtor ctor -> [classEntityExtName cls ctor] - CEMethod m -> [classEntityExtName cls m] - CEProp (Prop methods) -> map (classEntityExtName cls) methods - --- | A C++ member variable. -data ClassVariable = ClassVariable - { classVarCName :: String - -- ^ The variable's C++ name. - , classVarExtName :: ExtName - -- ^ The variable's external name. - , classVarType :: Type - -- ^ The variable's type. This may be - -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is - -- read-only. - , classVarStatic :: Staticness - -- ^ Whether the variable is static (i.e. whether it exists once in the - -- class itself and not in each instance). - , classVarGettable :: Bool - -- ^ Whether the variable should have an accompanying getter. Note this - -- exists only for disabling getters on callback variables - as there is - -- currently no functionality to pass callbacks out of c++ - } - -instance Show ClassVariable where - show v = - concat [""] - -instance IsClassEntity ClassVariable where - classEntityExtNameSuffix = classVarExtName - --- | Creates a 'ClassVariable' with full generality and manual name specification. --- --- The result is wrapped in a 'CEVar'. For an unwrapped value, use --- 'makeClassVariable_'. -makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity -makeClassVariable cName maybeExtName tp static gettable = - CEVar $ makeClassVariable_ cName maybeExtName tp static gettable - --- | The unwrapped version of 'makeClassVariable'. -makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable -makeClassVariable_ cName maybeExtName = - ClassVariable cName $ extNameOrString cName maybeExtName - --- | Creates a 'ClassVariable' for a nonstatic class variable for --- @class::varName@ whose external name is @class_varName@. --- --- The result is wrapped in a 'CEVar'. For an unwrapped value, use --- 'mkClassVariable_'. -mkClassVariable :: String -> Type -> ClassEntity -mkClassVariable = (CEVar .) . mkClassVariable_ - --- | The unwrapped version of 'mkClassVariable'. -mkClassVariable_ :: String -> Type -> ClassVariable -mkClassVariable_ cName t = makeClassVariable_ cName Nothing t Nonstatic True - --- | Same as 'mkClassVariable', but returns a static variable instead. --- --- The result is wrapped in a 'CEVar'. For an unwrapped value, use --- 'mkStaticClassVariable_'. -mkStaticClassVariable :: String -> Type -> ClassEntity -mkStaticClassVariable = (CEVar .) . mkStaticClassVariable_ - --- | The unwrapped version of 'mkStaticClassVariable'. -mkStaticClassVariable_ :: String -> Type -> ClassVariable -mkStaticClassVariable_ cName t = makeClassVariable_ cName Nothing t Static True - --- | Returns the external name of the getter function for the class variable. -classVarGetterExtName :: Class -> ClassVariable -> ExtName -classVarGetterExtName cls v = - toExtName $ fromExtName (classEntityExtName cls v) ++ "_get" - --- | Returns the foreign name of the getter function for the class variable. -classVarGetterForeignName :: Class -> ClassVariable -> ExtName -classVarGetterForeignName cls v = - toExtName $ fromExtName (classEntityForeignName cls v) ++ "_get" - --- | Returns the external name of the setter function for the class variable. -classVarSetterExtName :: Class -> ClassVariable -> ExtName -classVarSetterExtName cls v = - toExtName $ fromExtName (classEntityExtName cls v) ++ "_set" - --- | Returns the foreign name of the setter function for the class variable. -classVarSetterForeignName :: Class -> ClassVariable -> ExtName -classVarSetterForeignName cls v = - toExtName $ fromExtName (classEntityForeignName cls v) ++ "_set" - --- | A C++ class constructor declaration. -data Ctor = Ctor - { ctorExtName :: ExtName - -- ^ The constructor's external name. - , ctorParams :: [Type] - -- ^ The constructor's parameter types. - , ctorExceptionHandlers :: ExceptionHandlers - -- ^ Exceptions that the constructor may throw. - } - -instance Show Ctor where - show ctor = concat [""] - -instance HandlesExceptions Ctor where - getExceptionHandlers = ctorExceptionHandlers - modifyExceptionHandlers f ctor = ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor } - -instance IsClassEntity Ctor where - classEntityExtNameSuffix = ctorExtName - --- | Creates a 'Ctor' with full generality. --- --- The result is wrapped in a 'CECtor'. For an unwrapped value, use --- 'makeCtor_'. -makeCtor :: ExtName - -> [Type] -- ^ Parameter types. - -> ClassEntity -makeCtor = (CECtor .) . makeCtor_ - --- | The unwrapped version of 'makeCtor'. -makeCtor_ :: ExtName -> [Type] -> Ctor -makeCtor_ extName paramTypes = Ctor extName paramTypes mempty - --- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@. --- --- The result is wrapped in a 'CECtor'. For an unwrapped value, use --- 'makeCtor_'. -mkCtor :: String - -> [Type] -- ^ Parameter types. - -> ClassEntity -mkCtor = (CECtor .) . mkCtor_ - --- | The unwrapped version of 'mkCtor'. -mkCtor_ :: String -> [Type] -> Ctor -mkCtor_ = makeCtor_ . toExtName - --- | Searches a class for a copy constructor, returning it if found. -classFindCopyCtor :: Class -> Maybe Ctor -classFindCopyCtor cls = case mapMaybe check $ classEntities cls of - [ctor] -> Just ctor - _ -> Nothing - where check entity = case entity of - CECtor ctor -> - let params = map (stripConst . normalizeType) (ctorParams ctor) - in if params == [Internal_TObj cls] || - params == [Internal_TRef $ Internal_TConst $ Internal_TObj cls] - then Just ctor - else Nothing - _ -> Nothing - --- | A C++ class method declaration. --- --- Any operator function that can be written as a method may have its binding be --- written either as part of the associated class or as a separate entity, --- independently of how the function is declared in C++. -data Method = Method - { methodImpl :: MethodImpl - -- ^ The underlying code that the binding calls. - , methodExtName :: ExtName - -- ^ The method's external name. - , methodApplicability :: MethodApplicability - -- ^ How the method is associated to its class. - , methodPurity :: Purity - -- ^ Whether the method is pure. - , methodParams :: [Type] - -- ^ The method's parameter types. - , methodReturn :: Type - -- ^ The method's return type. - , methodExceptionHandlers :: ExceptionHandlers - -- ^ Exceptions that the method might throw. - } - -instance Show Method where - show method = - concat [" show name - FnMethod name -> show name, " ", - show (methodApplicability method), " ", - show (methodPurity method), " ", - show (methodParams method), " ", - show (methodReturn method), ">"] - -instance HandlesExceptions Method where - getExceptionHandlers = methodExceptionHandlers - - modifyExceptionHandlers f method = - method { methodExceptionHandlers = f $ methodExceptionHandlers method } - -instance IsClassEntity Method where - classEntityExtNameSuffix = methodExtName - --- | The C++ code to which a 'Method' is bound. -data MethodImpl = - RealMethod (FnName String) - -- ^ The 'Method' is bound to an actual class method. - | FnMethod (FnName Identifier) - -- ^ The 'Method' is bound to a wrapper function. When wrapping a method - -- with another function, this is preferrable to just using a 'Function' - -- binding because a method will still appear to be part of the class in - -- foreign bindings. - deriving (Eq, Show) - --- | How a method is associated to its class. A method may be static, const, or --- neither (a regular method). -data MethodApplicability = MNormal | MStatic | MConst - deriving (Bounded, Enum, Eq, Show) - --- | Whether or not a method is const. -data Constness = Nonconst | Const - deriving (Bounded, Enum, Eq, Show) - --- | Returns the opposite constness value. -constNegate :: Constness -> Constness -constNegate Nonconst = Const -constNegate Const = Nonconst - --- | Whether or not a method is static. -data Staticness = Nonstatic | Static - deriving (Bounded, Enum, Eq, Show) - --- | Returns the constness of a method, based on its 'methodApplicability'. -methodConst :: Method -> Constness -methodConst method = case methodApplicability method of - MConst -> Const - _ -> Nonconst - --- | Returns the staticness of a method, based on its 'methodApplicability'. -methodStatic :: Method -> Staticness -methodStatic method = case methodApplicability method of - MStatic -> Static - _ -> Nonstatic - --- | Creates a 'Method' with full generality and manual name specification. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'makeMethod_'. -makeMethod :: IsFnName String name - => name -- ^ The C++ name of the method. - -> ExtName -- ^ The external name of the method. - -> MethodApplicability - -> Purity - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> ClassEntity -makeMethod = (((((CEMethod .) .) .) .) .) . makeMethod_ - --- | The unwrapped version of 'makeMethod'. -makeMethod_ :: IsFnName String name - => name - -> ExtName - -> MethodApplicability - -> Purity - -> [Type] - -> Type - -> Method -makeMethod_ cName extName appl purity paramTypes retType = - Method (RealMethod $ toFnName cName) extName appl purity paramTypes retType mempty - --- | Creates a 'Method' that is in fact backed by a C++ non-member function (a --- la 'makeFn'), but appears to be a regular method. This is useful for --- wrapping a method on the C++ side when its arguments aren't right for binding --- directly. --- --- A @this@ pointer parameter is __not__ automatically added to the parameter --- list for non-static methods created with @makeFnMethod@. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'makeFnMethod_'. -makeFnMethod :: IsFnName Identifier name - => name - -> String - -> MethodApplicability - -> Purity - -> [Type] - -> Type - -> ClassEntity -makeFnMethod = (((((CEMethod .) .) .) .) .) . makeFnMethod_ - --- | The unwrapped version of 'makeFnMethod'. -makeFnMethod_ :: IsFnName Identifier name - => name - -> String - -> MethodApplicability - -> Purity - -> [Type] - -> Type - -> Method -makeFnMethod_ cName foreignName appl purity paramTypes retType = - Method (FnMethod $ toFnName cName) (toExtName foreignName) - appl purity paramTypes retType mempty - --- | This function is internal. --- --- Creates a method similar to 'makeMethod', but with automatic naming. The --- method's external name will be @className ++ \"_\" ++ cppMethodName@. If the --- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded --- to the class name. --- --- For creating multiple bindings to a method, see 'makeMethod''. -makeMethod' :: IsFnName String name - => name -- ^ The C++ name of the method. - -> MethodApplicability - -> Purity - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> Method -makeMethod' name = makeMethod''' (toFnName name) Nothing - --- | This function is internal. --- --- Creates a method similar to 'makeMethod'', but with an custom string that --- will be appended to the class name to form the method's external name. This --- is useful for making multiple bindings to a method, e.g. for overloading and --- optional arguments. -makeMethod'' :: IsFnName String name - => name -- ^ The C++ name of the method. - -> String -- ^ A foreign name for the method. - -> MethodApplicability - -> Purity - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> Method -makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName - --- | The implementation of 'makeMethod'' and 'makeMethod'''. -makeMethod''' :: FnName String -- ^ The C++ name of the method. - -> Maybe String -- ^ A foreign name for the method. - -> MethodApplicability - -> Purity - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> Method -makeMethod''' (FnName "") maybeForeignName _ _ paramTypes retType = - error $ concat ["makeMethod''': Given an empty method name with foreign name ", - show maybeForeignName, ", parameter types ", show paramTypes, - ", and return type ", show retType, "."] -makeMethod''' name (Just "") _ _ paramTypes retType = - error $ concat ["makeMethod''': Given an empty foreign name with method ", - show name, ", parameter types ", show paramTypes, ", and return type ", - show retType, "."] -makeMethod''' name maybeForeignName appl purity paramTypes retType = - let extName = flip fromMaybe (toExtName <$> maybeForeignName) $ case name of - FnName s -> toExtName s - FnOp op -> operatorPreferredExtName op - in makeMethod_ name extName appl purity paramTypes retType - --- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose --- external name is @class_methodName@. If the name is an operator, then the --- 'operatorPreferredExtName' will be used in the external name. --- --- For creating multiple bindings to a method, see 'mkMethod''. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkMethod_'. -mkMethod :: IsFnName String name - => name -- ^ The C++ name of the method. - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> ClassEntity -mkMethod = ((CEMethod .) .) . mkMethod_ - --- | The unwrapped version of 'mkMethod'. -mkMethod_ :: IsFnName String name - => name - -> [Type] - -> Type - -> Method -mkMethod_ name = makeMethod' name MNormal Nonpure - --- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and --- whose external name is @class_methodName@. This enables multiple 'Method's --- with different foreign names (and hence different external names) to bind to --- the same method, e.g. to make use of optional arguments or overloading. See --- 'mkMethod' for a simpler form. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkMethod'_'. -mkMethod' :: IsFnName String name - => name -- ^ The C++ name of the method. - -> String -- ^ A foreign name for the method. - -> [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> ClassEntity -mkMethod' = (((CEMethod .) .) .) . mkMethod'_ - --- | The unwrapped version of 'mkMethod''. -mkMethod'_ :: IsFnName String name - => name - -> String - -> [Type] - -> Type - -> Method -mkMethod'_ cName foreignName = makeMethod'' cName foreignName MNormal Nonpure - --- | Same as 'mkMethod', but returns an 'MConst' method. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkConstMethod_'. -mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity -mkConstMethod = ((CEMethod .) .) . mkConstMethod_ - --- | The unwrapped version of 'mkConstMethod'. -mkConstMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method -mkConstMethod_ name = makeMethod' name MConst Nonpure - --- | Same as 'mkMethod'', but returns an 'MConst' method. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkConstMethod'_'. -mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity -mkConstMethod' = (((CEMethod .) .) .) . mkConstMethod'_ - --- | The unwrapped version of 'mkConstMethod''. -mkConstMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method -mkConstMethod'_ cName foreignName = makeMethod'' cName foreignName MConst Nonpure - --- | Same as 'mkMethod', but returns an 'MStatic' method. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkStaticMethod_'. -mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity -mkStaticMethod = ((CEMethod .) .) . mkStaticMethod_ - --- | The unwrapped version of 'mkStaticMethod'. -mkStaticMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method -mkStaticMethod_ name = makeMethod' name MStatic Nonpure - --- | Same as 'mkMethod'', but returns an 'MStatic' method. --- --- The result is wrapped in a 'CEMethod'. For an unwrapped value, use --- 'mkStaticMethod'_'. -mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity -mkStaticMethod' = (((CEMethod .) .) .) . mkStaticMethod'_ - --- | The unwrapped version of 'mkStaticMethod''. -mkStaticMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method -mkStaticMethod'_ cName foreignName = makeMethod'' cName foreignName MStatic Nonpure - --- | A \"property\" getter/setter pair. -newtype Prop = Prop [Method] - --- | Creates a getter/setter binding pair for methods: --- --- > T foo() const --- > void setFoo(T) --- --- The result is wrapped in a 'CEProp'. For an unwrapped value, use --- 'mkProp_'. -mkProp :: String -> Type -> ClassEntity -mkProp = (CEProp .) . mkProp_ - --- | The unwrapped version of 'mkProp'. -mkProp_ :: String -> Type -> Prop -mkProp_ name t = - let c:cs = name - setName = 's' : 'e' : 't' : toUpper c : cs - in Prop [ mkConstMethod_ name [] t - , mkMethod_ setName [t] Internal_TVoid - ] - --- | Creates a getter/setter binding pair for static methods: --- --- > static T foo() const --- > static void setFoo(T) -mkStaticProp :: String -> Type -> ClassEntity -mkStaticProp = (CEProp .) . mkStaticProp_ - --- | The unwrapped version of 'mkStaticProp'. -mkStaticProp_ :: String -> Type -> Prop -mkStaticProp_ name t = - let c:cs = name - setName = 's' : 'e' : 't' : toUpper c : cs - in Prop [ mkStaticMethod_ name [] t - , mkStaticMethod_ setName [t] Internal_TVoid - ] - --- | Creates a getter/setter binding pair for boolean methods, where the getter --- is prefixed with @is@: --- --- > bool isFoo() const --- > void setFoo(bool) --- --- The result is wrapped in a 'CEProp'. For an unwrapped value, use --- 'mkBoolIsProp_'. -mkBoolIsProp :: String -> ClassEntity -mkBoolIsProp = CEProp . mkBoolIsProp_ - --- | The unwrapped version of 'mkBoolIsProp'. -mkBoolIsProp_ :: String -> Prop -mkBoolIsProp_ name = - let c:cs = name - name' = toUpper c : cs - isName = 'i':'s':name' - setName = 's':'e':'t':name' - in Prop [ mkConstMethod_ isName [] Internal_TBool - , mkMethod_ setName [Internal_TBool] Internal_TVoid - ] - --- | Creates a getter/setter binding pair for boolean methods, where the getter --- is prefixed with @has@: --- --- > bool hasFoo() const --- > void setFoo(bool) --- --- The result is wrapped in a 'CEProp'. For an unwrapped value, use --- 'mkBoolHasProp_'. -mkBoolHasProp :: String -> ClassEntity -mkBoolHasProp = CEProp . mkBoolHasProp_ - --- | The unwrapped version of 'mkBoolHasProp'. -mkBoolHasProp_ :: String -> Prop -mkBoolHasProp_ name = - let c:cs = name - name' = toUpper c : cs - hasName = 'h':'a':'s':name' - setName = 's':'e':'t':name' - in Prop [ mkConstMethod_ hasName [] Internal_TBool - , mkMethod_ setName [Internal_TBool] Internal_TVoid - ] - --- | A non-C++ function that can be invoked via a C++ functor or function --- pointer. --- --- Use this data type's 'HasReqs' instance to add extra requirements, however --- manually adding requirements for parameter and return types is not necessary. -data Callback = Callback - { callbackExtName :: ExtName - -- ^ The callback's external name. - , callbackParams :: [Type] - -- ^ The callback's parameter types. - , callbackReturn :: Type - -- ^ The callback's return type. - , callbackThrows :: Maybe Bool - -- ^ Whether the callback supports throwing C++ exceptions from Haskell into - -- C++ during its execution. When absent, the value is inherited from - -- 'moduleCallbacksThrow' and 'interfaceCallbacksThrow'. - , callbackReqs :: Reqs - -- ^ Extra requirements for the callback. - , callbackAddendum :: Addendum - -- ^ The callback's addendum. - } - -instance Eq Callback where - (==) = (==) `on` callbackExtName - -instance Show Callback where - show cb = - concat [" [Type] -- ^ Parameter types. - -> Type -- ^ Return type. - -> Callback -makeCallback extName paramTypes retType = - Callback extName paramTypes retType Nothing mempty mempty - --- | Sets whether a callback supports handling thrown C++ exceptions and passing --- them into C++. -callbackSetThrows :: Bool -> Callback -> Callback -callbackSetThrows value cb = cb { callbackThrows = Just value } - --- | Each exception class has a unique exception ID. -newtype ExceptionId = ExceptionId - { getExceptionId :: Int -- ^ Internal. - } deriving (Eq, Show) - --- | The exception ID that represents the catch-all type. -exceptionCatchAllId :: ExceptionId -exceptionCatchAllId = ExceptionId 1 - --- | The lowest exception ID to be used for classes. -exceptionFirstFreeId :: Int -exceptionFirstFreeId = getExceptionId exceptionCatchAllId + 1 - --- | Indicates the ability to handle a certain type of C++ exception. -data ExceptionHandler = - CatchClass Class - -- ^ Indicates that instances of the given class are handled (including - -- derived types). - | CatchAll - -- ^ Indicates that all C++ exceptions are handled, i.e. @catch (...)@. - deriving (Eq, Ord) - --- | Represents a list of exception handlers to be used for a body of code. --- Order is important; a 'CatchAll' will prevent all subsequent handlers from --- being invoked. -data ExceptionHandlers = ExceptionHandlers - { exceptionHandlersList :: [ExceptionHandler] - -- ^ Extracts the list of exception handlers. - } - -instance Sem.Semigroup ExceptionHandlers where - (<>) e1 e2 = - ExceptionHandlers $ exceptionHandlersList e1 ++ exceptionHandlersList e2 - -instance Monoid ExceptionHandlers where - mempty = ExceptionHandlers [] - - mappend = (<>) - --- | Types that can handle exceptions. -class HandlesExceptions a where - -- | Extracts the exception handlers for an object. - getExceptionHandlers :: a -> ExceptionHandlers - - -- | Modifies an object's exception handlers with a given function. - modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> a -> a - --- | Appends additional exception handlers to an object. -handleExceptions :: HandlesExceptions a => [ExceptionHandler] -> a -> a -handleExceptions classes = - modifyExceptionHandlers $ mappend mempty { exceptionHandlersList = classes } - --- | A literal piece of code that will be inserted into a generated source file --- after the regular binding glue. The 'Monoid' instance concatenates code --- (actions). -data Addendum = Addendum - { addendumHaskell :: Haskell.Generator () - -- ^ Code to be output into the Haskell binding. May also add imports and - -- exports. - } - -instance Sem.Semigroup Addendum where - (<>) (Addendum a) (Addendum b) = Addendum $ a >> b - -instance Monoid Addendum where - mempty = Addendum $ return () - mappend = (<>) - --- | A typeclass for types that have an addendum. -class HasAddendum a where - {-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-} - - -- | Returns an object's addendum. - getAddendum :: a -> Addendum - - -- | Replaces and object's addendum with another. - setAddendum :: Addendum -> a -> a - setAddendum addendum = modifyAddendum $ const addendum - - -- | Modified an object's addendum. - modifyAddendum :: (Addendum -> Addendum) -> a -> a - modifyAddendum f x = setAddendum (f $ getAddendum x) x - --- | Adds a Haskell addendum to an object. -addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a -addAddendumHaskell gen = modifyAddendum $ \addendum -> - addendum `mappend` mempty { addendumHaskell = gen } - --- | A collection of imports for a Haskell module. This is a monoid: import --- Statements are merged to give the union of imported bindings. --- --- This structure supports two specific types of imports: --- - @import Foo (...)@ --- - @import qualified Foo as Bar@ --- Imports with @as@ but without @qualified@, and @qualified@ imports with a --- spec list, are not supported. This satisfies the needs of the code --- generator, and keeps the merging logic simple. -newtype HsImportSet = HsImportSet - { getHsImportSet :: M.Map HsImportKey HsImportSpecs - -- ^ Returns the import set's internal map from module names to imported - -- bindings. - } deriving (Show) - -instance Sem.Semigroup HsImportSet where - (<>) (HsImportSet m) (HsImportSet m') = - HsImportSet $ M.unionWith mergeImportSpecs m m' - -instance Monoid HsImportSet where - mempty = HsImportSet M.empty - - mappend = (<>) - - mconcat sets = - HsImportSet $ M.unionsWith mergeImportSpecs $ map getHsImportSet sets - --- | Constructor for an import set. -makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet -makeHsImportSet = HsImportSet - --- | Sets all of the import specifications in an import set to be --- @{-#SOURCE#-}@ imports. -hsImportSetMakeSource :: HsImportSet -> HsImportSet -hsImportSetMakeSource (HsImportSet m) = - HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m - --- | A Haskell module name. -type HsModuleName = String - --- | References an occurrence of an import statement, under which bindings can --- be imported. Only imported specs under equal 'HsImportKey's may be merged. -data HsImportKey = HsImportKey - { hsImportModule :: HsModuleName - , hsImportQualifiedName :: Maybe HsModuleName - } deriving (Eq, Ord, Show) - --- | A specification of bindings to import from a module. If 'Nothing', then --- the entire module is imported. If @'Just' 'M.empty'@, then only instances --- are imported. -data HsImportSpecs = HsImportSpecs - { getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal) - , hsImportSource :: Bool - } deriving (Show) - --- | Combines two 'HsImportSpecs's into one that imports everything that the two --- did separately. -mergeImportSpecs :: HsImportSpecs -> HsImportSpecs -> HsImportSpecs -mergeImportSpecs (HsImportSpecs mm s) (HsImportSpecs mm' s') = - HsImportSpecs (liftM2 mergeMaps mm mm') (s || s') - where mergeMaps = M.unionWith mergeValues - mergeValues v v' = case (v, v') of - (HsImportValAll, _) -> HsImportValAll - (_, HsImportValAll) -> HsImportValAll - (HsImportValSome s, HsImportValSome s') -> HsImportValSome $ s ++ s' - (x@(HsImportValSome _), _) -> x - (_, x@(HsImportValSome _)) -> x - (HsImportVal, HsImportVal) -> HsImportVal - --- | An identifier that can be imported from a module. Symbols may be used here --- when surrounded by parentheses. Examples are @\"fmap\"@ and @\"(++)\"@. -type HsImportName = String - --- | Specifies how a name is imported. -data HsImportVal = - HsImportVal - -- ^ The name is imported, and nothing underneath it is. - | HsImportValSome [HsImportName] - -- ^ The name is imported, as are specific names underneath it. This is a - -- @X (a, b, c)@ import. - | HsImportValAll - -- ^ The name is imported, along with all names underneath it. This is a @X - -- (..)@ import. - deriving (Show) - --- | An import for the entire contents of a Haskell module. -hsWholeModuleImport :: HsModuleName -> HsImportSet -hsWholeModuleImport moduleName = - HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $ - HsImportSpecs Nothing False - --- | A qualified import of a Haskell module. -hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet -hsQualifiedImport moduleName qualifiedName = - HsImportSet $ M.singleton (HsImportKey moduleName $ Just qualifiedName) $ - HsImportSpecs Nothing False - --- | An import of a single name from a Haskell module. -hsImport1 :: HsModuleName -> HsImportName -> HsImportSet -hsImport1 moduleName valueName = hsImport1' moduleName valueName HsImportVal - --- | A detailed import of a single name from a Haskell module. -hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet -hsImport1' moduleName valueName valueType = - HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $ - HsImportSpecs (Just $ M.singleton valueName valueType) False - --- | An import of multiple names from a Haskell module. -hsImports :: HsModuleName -> [HsImportName] -> HsImportSet -hsImports moduleName names = - hsImports' moduleName $ map (\name -> (name, HsImportVal)) names - --- | A detailed import of multiple names from a Haskell module. -hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet -hsImports' moduleName values = - HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $ - HsImportSpecs (Just $ M.fromList values) False - --- | Imports "Data.Bits" qualified as @HoppyDB@. -hsImportForBits :: HsImportSet -hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB" - --- | Imports "Control.Exception" qualified as @HoppyCE@. -hsImportForException :: HsImportSet -hsImportForException = hsQualifiedImport "Control.Exception" "HoppyCE" - --- | Imports "Data.Int" qualified as @HoppyDI@. -hsImportForInt :: HsImportSet -hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI" - --- | Imports "Data.Word" qualified as @HoppyDW@. -hsImportForWord :: HsImportSet -hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW" - --- | Imports "Foreign" qualified as @HoppyF@. -hsImportForForeign :: HsImportSet -hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF" - --- | Imports "Foreign.C" qualified as @HoppyFC@. -hsImportForForeignC :: HsImportSet -hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC" - --- | Imports "Data.Map" qualified as @HoppyDM@. -hsImportForMap :: HsImportSet -hsImportForMap = hsQualifiedImport "Data.Map" "HoppyDM" - --- | Imports "Prelude" qualified as @HoppyP@. -hsImportForPrelude :: HsImportSet -hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP" - --- | Imports "Foreign.Hoppy.Runtime" qualified as @HoppyFHR@. -hsImportForRuntime :: HsImportSet -hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR" - --- | Imports "System.Posix.Types" qualified as @HoppySPT@. -hsImportForSystemPosixTypes :: HsImportSet -hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT" - --- | Imports "Data.Typeable" qualified as @HoppyDT@. -hsImportForTypeable :: HsImportSet -hsImportForTypeable = hsQualifiedImport "Data.Typeable" "HoppyDT" +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + +module Foreign.Hoppy.Generator.Spec.Base ( + ErrorMsg, + -- * Interfaces + Interface, + InterfaceOptions (..), + defaultInterfaceOptions, + interface, + interface', + interfaceName, + interfaceModules, + interfaceNamesToModules, + interfaceHaskellModuleBase, + interfaceDefaultHaskellModuleBase, + interfaceAddHaskellModuleBase, + interfaceHaskellModuleImportNames, + interfaceExceptionHandlers, + interfaceCallbacksThrow, + interfaceSetCallbacksThrow, + interfaceExceptionClassId, + interfaceExceptionSupportModule, + interfaceSetExceptionSupportModule, + interfaceSetSharedPtr, + interfaceCompiler, + interfaceSetCompiler, + interfaceSetCompiler', + interfaceSetNoCompiler, + interfaceValidateEnumTypes, + interfaceSetValidateEnumTypes, + interfaceHooks, + interfaceModifyHooks, + -- * C++ includes + Include, + includeStd, + includeLocal, + includeToString, + -- * Modules + Module, + moduleName, + moduleHppPath, + moduleCppPath, + moduleExports, + moduleReqs, + moduleExceptionHandlers, + moduleCallbacksThrow, + moduleSetCallbacksThrow, + moduleAddendum, + moduleHaskellName, + makeModule, + moduleModify, + moduleModify', + moduleSetHppPath, + moduleSetCppPath, + moduleAddExports, + moduleAddHaskellName, + -- * Requirements + Reqs, + reqsIncludes, + reqInclude, + HasReqs (..), + addReqs, + addReqIncludes, + -- * Names + ExtName, + toExtName, + extNameOrIdentifier, + extNameOrFnIdentifier, + extNameOrString, + isValidExtName, + fromExtName, + HasExtNames (..), + getAllExtNames, + FnName (..), + IsFnName (..), + Operator (..), + OperatorType (..), + operatorPreferredExtName, + operatorPreferredExtName', + operatorType, + Identifier, + makeIdentifier, + identifierParts, + IdPart, + makeIdPart, + idPartBase, + idPartArgs, + ident, ident', ident1, ident2, ident3, ident4, ident5, + identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T, + -- * Exports + Exportable (..), + Export (..), + -- * Basic types + Type (..), + normalizeType, + stripConst, + -- * Functions and parameters + Constness (..), constNegate, + Purity (..), + Parameter, parameterType, parameterName, + IsParameter (..), toParameters, + np, (~:), + -- * Conversions + ConversionMethod (..), + ConversionSpec (conversionSpecName, conversionSpecCpp, conversionSpecHaskell), + makeConversionSpec, + ConversionSpecCpp ( + ConversionSpecCpp, + conversionSpecCppName, + conversionSpecCppReqs, + conversionSpecCppConversionType, + conversionSpecCppConversionToCppExpr, + conversionSpecCppConversionFromCppExpr + ), + makeConversionSpecCpp, + ConversionSpecHaskell ( + ConversionSpecHaskell, + conversionSpecHaskellHsType, + conversionSpecHaskellHsArgType, + conversionSpecHaskellCType, + conversionSpecHaskellToCppFn, + conversionSpecHaskellFromCppFn + ), + makeConversionSpecHaskell, + -- * Exceptions + ExceptionId (..), + exceptionCatchAllId, + ExceptionHandler (..), + ExceptionHandlers (..), + HandlesExceptions (..), + handleExceptions, + -- * Addenda + Addendum (..), + HasAddendum (..), + addAddendumHaskell, + -- * Enum support + EnumInfo (..), + EnumEntryWords, + EnumValueMap (..), + EnumValue (..), + -- * Languages + ForeignLanguage (..), + WithForeignLanguageOverrides, + MapWithForeignLanguageOverrides, + -- * Haskell imports + HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..), + hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports', + hsImportSetMakeSource, + -- * Internal to Hoppy + EvaluatedEnumData (..), + EvaluatedEnumValueMap, + interfaceAllExceptionClasses, + interfaceSharedPtr, + interfaceEvaluatedEnumData, + interfaceGetEvaluatedEnumData, + -- ** Haskell imports + makeHsImportSet, + getHsImportSet, + hsImportForBits, + hsImportForException, + hsImportForInt, + hsImportForWord, + hsImportForForeign, + hsImportForForeignC, + hsImportForMap, + hsImportForPrelude, + hsImportForRuntime, + hsImportForSystemPosixTypes, + hsImportForUnsafeIO, + -- ** Error messages + objToHeapTWrongDirectionErrorMsg, + tToGcInvalidFormErrorMessage, + toGcTWrongDirectionErrorMsg, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Arrow ((&&&)) +import Control.Monad (liftM2, unless) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except (MonadError, throwError) +#else +import Control.Monad.Error (MonadError, throwError) +#endif +import Control.Monad.State (MonadState, StateT, execStateT, get, modify, put) +import Data.Char (isAlpha, isAlphaNum) +import Data.Function (on) +import Data.List (intercalate, intersperse) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, mappend, mconcat, mempty) +#endif +import Data.Semigroup as Sem +import qualified Data.Set as S +import Data.Typeable (Typeable, cast) +import Foreign.Hoppy.Generator.Common +import Foreign.Hoppy.Generator.Compiler (Compiler, SomeCompiler (SomeCompiler), defaultCompiler) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Hook (Hooks, defaultHooks) +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import Foreign.Hoppy.Generator.Override (MapWithOverrides, WithOverrides) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (Class, classExtName) +import GHC.Stack (HasCallStack) +import Language.Haskell.Syntax (HsName, HsQualType, HsType) + +-- | Indicates strings that are error messages. +type ErrorMsg = String + +-- | A complete specification of a C++ API. Generators for different languages, +-- including the binding generator for C++, use these to produce their output. +-- +-- 'Interface' does not have a 'HandlesExceptions' instance because +-- 'modifyExceptionHandlers' does not work for it (handled exceptions cannot be +-- modified after an 'Interface' is constructed). +data Interface = Interface + { interfaceName :: String + -- ^ The textual name of the interface. + , interfaceModules :: M.Map String Module + -- ^ All of the individual modules, by 'moduleName'. + , interfaceNamesToModules :: M.Map ExtName Module + -- ^ Maps each 'ExtName' exported by some module to the module that exports + -- the name. + , interfaceHaskellModuleBase' :: Maybe [String] + -- ^ See 'interfaceHaskellModuleBase'. + , interfaceHaskellModuleImportNames :: M.Map Module String + -- ^ Short qualified module import names that generated modules use to refer + -- to each other tersely. + , interfaceExceptionHandlers :: ExceptionHandlers + -- ^ Exceptions that all functions in the interface may throw. + , interfaceCallbacksThrow :: Bool + -- ^ Whether callbacks within the interface support throwing C++ exceptions + -- from Haskell into C++ during their execution. This may be overridden by + -- 'moduleCallbacksThrow' and + -- 'Foreign.Hoppy.Generator.Spec.Callback.callbackThrows'. + , interfaceExceptionNamesToIds :: M.Map ExtName ExceptionId + -- ^ Maps from external names of exception classes to their exception IDs. + , interfaceExceptionSupportModule :: Maybe Module + -- ^ When an interface uses C++ exceptions, then one module needs to + -- manually be selected to contain some interface-specific runtime support. + -- This is the selected module. + , interfaceSharedPtr :: (Reqs, String) + -- ^ The name of the @shared_ptr@ class to use, and the requirements to use + -- it. This defaults to using @std::shared_ptr@ from @\@, but can + -- be changed if necessary via 'interfaceSetSharedPtr'. + , interfaceCompiler :: Maybe SomeCompiler + -- ^ The compiler to use when building code for the interface. This can be + -- overridden or disabled. This defaults to 'defaultCompiler'. + , interfaceHooks :: Hooks + -- ^ Hooks allowing the interface to execute code at various points during + -- the code generator's execution. This defaults to 'defaultHooks'. + , interfaceEvaluatedEnumData :: Maybe (M.Map ExtName EvaluatedEnumData) + -- ^ Evaluated numeric types and values for all enums in the interface. + , interfaceValidateEnumTypes :: Bool + -- ^ Whether to validate manually-provided enum numeric types + -- ('Foreign.Hoppy.Generator.Spec.Enum.enumNumericType') using a compiled + -- C++ @sizeof()@, as is done for enums that don't have an @enumNumericType@ + -- set. + -- + -- This defaults to true, but can be set to false to discourage requiring a + -- compiler. See 'interfaceSetNoCompiler'. + } + +instance Show Interface where + show iface = concat [""] + +instance HasExports Interface where + lookupExport name iface = + lookupExport name =<< M.lookup name (interfaceNamesToModules iface) + +-- | Optional parameters when constructing an 'Interface' with 'interface'. +newtype InterfaceOptions = InterfaceOptions + { interfaceOptionsExceptionHandlers :: ExceptionHandlers + } + +-- | Options used by 'interface'. This contains no exception handlers. +defaultInterfaceOptions :: InterfaceOptions +defaultInterfaceOptions = InterfaceOptions mempty + +-- | Constructs an 'Interface' from the required parts. Some validation is +-- performed; if the resulting interface would be invalid, an error message is +-- returned instead. +-- +-- This function passes 'defaultInterfaceOptions' to 'interface''. +interface :: String -- ^ 'interfaceName' + -> [Module] -- ^ 'interfaceModules' + -> Either ErrorMsg Interface +interface ifName modules = interface' ifName modules defaultInterfaceOptions + +-- | Same as 'interface', but accepts some optional arguments. +interface' :: String -- ^ 'interfaceName' + -> [Module] -- ^ 'interfaceModules' + -> InterfaceOptions + -> Either ErrorMsg Interface +interface' ifName modules options = do + -- TODO Check for duplicate module names. + -- TODO Check for duplicate module file paths. + + -- Check for multiple modules exporting an ExtName. + let extNamesToModules :: M.Map ExtName [Module] + extNamesToModules = + M.unionsWith (++) $ + for modules $ \m -> + let extNames = concatMap getAllExtNames $ M.elems $ moduleExports m + in M.fromList $ zip extNames $ repeat [m] + + extNamesInMultipleModules :: [(ExtName, [Module])] + extNamesInMultipleModules = + M.toList $ + M.filter (\case + _:_:_ -> True + _ -> False) + extNamesToModules + + unless (null extNamesInMultipleModules) $ + Left $ unlines $ + "Some external name(s) are exported by multiple modules:" : + map (\(extName, modules') -> + concat $ "- " : show extName : ": " : intersperse ", " (map show modules')) + extNamesInMultipleModules + + let haskellModuleImportNames = + M.fromList $ + (\a b f -> zipWith f a b) modules [(1::Int)..] $ + \m index -> (m, 'M' : show index) + + -- Generate a unique exception ID integer for each exception class. IDs 0 and + -- 1 are reserved. + let exceptionNamesToIds = + M.fromList $ + zip (map classExtName $ interfaceAllExceptionClasses' modules) + (map ExceptionId [exceptionFirstFreeId..]) + + return Interface + { interfaceName = ifName + , interfaceModules = M.fromList $ map (moduleName &&& id) modules + , interfaceNamesToModules = M.map (\[x] -> x) extNamesToModules + , interfaceHaskellModuleBase' = Nothing + , interfaceHaskellModuleImportNames = haskellModuleImportNames + , interfaceExceptionHandlers = interfaceOptionsExceptionHandlers options + , interfaceCallbacksThrow = False + , interfaceExceptionNamesToIds = exceptionNamesToIds + , interfaceExceptionSupportModule = Nothing + , interfaceSharedPtr = (reqInclude $ includeStd "memory", "std::shared_ptr") + , interfaceCompiler = Just $ SomeCompiler defaultCompiler + , interfaceHooks = defaultHooks + , interfaceEvaluatedEnumData = Nothing + , interfaceValidateEnumTypes = True + } + +-- | The name of the parent Haskell module under which a Haskell module will be +-- generated for a Hoppy 'Module'. This is a list of Haskell module path +-- components, in other words, @'Data.List.intercalate' "."@ on the list +-- produces a Haskell module name. Defaults to +-- 'interfaceDefaultHaskellModuleBase', and may be overridden with +-- 'interfaceAddHaskellModuleBase'. +interfaceHaskellModuleBase :: Interface -> [String] +interfaceHaskellModuleBase = + fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase' + +-- | The default Haskell module under which Hoppy modules will be generated. +-- This is @Foreign.Hoppy.Generated@, that is: +-- +-- > ["Foreign", "Hoppy", "Generated"] +interfaceDefaultHaskellModuleBase :: [String] +interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"] + +-- | Sets an interface to generate all of its modules under the given Haskell +-- module prefix. See 'interfaceHaskellModuleBase'. +interfaceAddHaskellModuleBase :: [String] -> Interface -> Either String Interface +interfaceAddHaskellModuleBase modulePath iface = case interfaceHaskellModuleBase' iface of + Nothing -> Right iface { interfaceHaskellModuleBase' = Just modulePath } + Just existingPath -> + Left $ concat + [ "addInterfaceHaskellModuleBase: Trying to add Haskell module base " + , intercalate "." modulePath, " to ", show iface + , " which already has a module base ", intercalate "." existingPath + ] + +-- | Returns the the exception ID for a class in an interface, if it has one +-- (i.e. if it's been marked as an exception class with +-- 'Foreign.Hoppy.Generator.Spec.Class.classMakeException'). +interfaceExceptionClassId :: Interface -> Class -> Maybe ExceptionId +interfaceExceptionClassId iface cls = + M.lookup (classExtName cls) $ interfaceExceptionNamesToIds iface + +-- | Returns all of the exception classes in an interface. +interfaceAllExceptionClasses :: Interface -> [Class] +interfaceAllExceptionClasses = interfaceAllExceptionClasses' . M.elems . interfaceModules + +interfaceAllExceptionClasses' :: [Module] -> [Class] +interfaceAllExceptionClasses' modules = + flip concatMap modules $ \m -> + catMaybes $ + map getExportExceptionClass $ + M.elems $ moduleExports m + +-- | Changes 'Foreign.Hoppy.Generator.Spec.Callback.callbackThrows' for all +-- callbacks in an interface that don't have it set explicitly at the module or +-- callback level. +interfaceSetCallbacksThrow :: Bool -> Interface -> Interface +interfaceSetCallbacksThrow b iface = iface { interfaceCallbacksThrow = b } + +-- | Sets an interface's exception support module, for interfaces that use +-- exceptions. +interfaceSetExceptionSupportModule :: HasCallStack => Module -> Interface -> Interface +interfaceSetExceptionSupportModule m iface = case interfaceExceptionSupportModule iface of + Nothing -> iface { interfaceExceptionSupportModule = Just m } + Just existingMod -> + if m == existingMod + then iface + else error $ "interfaceSetExceptionSupportModule: " ++ show iface ++ + " already has exception support module " ++ show existingMod ++ + ", trying to set " ++ show m ++ "." + +-- | Installs a custom @std::shared_ptr@ implementation for use by an interface. +-- Hoppy uses shared pointers for generated callback code. This function is +-- useful for building code with compilers that don't provide a conforming +-- @std::shared_ptr@ implementation. +-- +-- @interfaceSetSharedPtr ident reqs iface@ modifies @iface@ to use as a +-- @shared_ptr@ class the C++ identifier @ident@, which needs @reqs@ in order to +-- be accessed. @ident@ should be the name of a template to which an arbitrary +-- @\@ can be appended, for example @"std::shared_ptr"@. +-- +-- A @shared_ptr\@ implementation @foo@ must at least provide the following +-- interface: +-- +-- > foo(); // Initialization with a null pointer. +-- > foo(T*); // Initialization with a given pointer. +-- > foo(const foo&); // Copy-construction. +-- > T& operator*() const; // Dereferencing (when non-null). +-- > T* operator->() const; // Dereferencing and invocation (when non-null). +-- > explicit operator bool() const; // Is the target object null? +interfaceSetSharedPtr :: String -> Reqs -> Interface -> Interface +interfaceSetSharedPtr identifier reqs iface = + iface { interfaceSharedPtr = (reqs, identifier) } + +-- | Replaces the default compiler used by the interface. +-- +-- @interfaceSetCompiler c = 'interfaceSetCompiler'' ('SomeCompiler' c)@ +interfaceSetCompiler :: Compiler a => a -> Interface -> Interface +interfaceSetCompiler = interfaceSetCompiler' . Just . SomeCompiler + +-- | Replaces the default compiler used by the interface. When given @Nothing@, +-- the interface will not be allowed to compile any code when it generates +-- bindings. +interfaceSetCompiler' :: Maybe SomeCompiler -> Interface -> Interface +interfaceSetCompiler' compiler iface = iface { interfaceCompiler = compiler } + +-- | Sets an interface to never compile C++ code during binding generation. +-- +-- This sets the interface to have no compiler, and also asks the interface not +-- to do things that require a compiler, which would otherwise cause a runtime +-- failure: currently just validation of provided enum numeric types +-- (@'interfaceSetValidateEnumTypes' False@). +interfaceSetNoCompiler :: Interface -> Interface +interfaceSetNoCompiler = + interfaceSetValidateEnumTypes False . + interfaceSetCompiler' Nothing + +-- | Controls whether the interface will validate manually specified enum types +-- ('Foreign.Hoppy.Generator.Spec.Enum.enumNumericType') by compiling a C++ +-- program. +-- +-- See 'interfaceValidateEnumTypes'. +interfaceSetValidateEnumTypes :: Bool -> Interface -> Interface +interfaceSetValidateEnumTypes validate iface = + iface { interfaceValidateEnumTypes = validate } + +-- | Modifies the hooks associated with an interface. +interfaceModifyHooks :: (Hooks -> Hooks) -> Interface -> Interface +interfaceModifyHooks f iface = + iface { interfaceHooks = f $ interfaceHooks iface } + +-- | Returns the map containing the calculated values for all entries in the +-- enum with the given 'ExtName'. This requires hooks to have been run. +interfaceGetEvaluatedEnumData :: HasCallStack => Interface -> ExtName -> EvaluatedEnumData +interfaceGetEvaluatedEnumData iface extName = + case interfaceEvaluatedEnumData iface of + Nothing -> error $ "interfaceGetEvaluatedEnumData: Data have not been " ++ + "evaluated for " ++ show iface ++ "." + Just enumMap -> case M.lookup extName enumMap of + Nothing -> error $ "interfaceGetEvaluatedEnumData: No data found for " ++ + show extName ++ " in " ++ show iface ++ "." + Just info -> info + +-- | An @#include@ directive in a C++ file. +newtype Include = Include + { includeToString :: String + -- ^ Returns the complete @#include ...@ line for an include, including + -- trailing newline. + } deriving (Eq, Ord, Show) + +-- | Creates an @#include \<...\>@ directive. +includeStd :: String -> Include +includeStd path = Include $ "#include <" ++ path ++ ">\n" + +-- | Creates an @#include "..."@ directive. +includeLocal :: String -> Include +includeLocal path = Include $ "#include \"" ++ path ++ "\"\n" + +-- | A portion of functionality in a C++ API. An 'Interface' is composed of +-- multiple modules. A module will generate a single compilation unit +-- containing bindings for all of the module's exports. The C++ code for a +-- generated module will @#include@ everything necessary for what is written to +-- the header and source files separately. You can declare include dependencies +-- with e.g. 'addReqIncludes', either for individual exports or at the module +-- level (via the @'HasReqs' 'Module'@ instance). Dependencies between modules +-- are handled automatically, and circularity is supported to a certain extent. +-- See the documentation for the individual language modules for further +-- details. +data Module = Module + { moduleName :: String + -- ^ The module's name. A module name must identify a unique module within + -- an 'Interface'. + , moduleHppPath :: String + -- ^ A relative path under a C++ sources root to which the generator will + -- write a header file for the module's C++ bindings. + , moduleCppPath :: String + -- ^ A relative path under a C++ sources root to which the generator will + -- write a source file for the module's C++ bindings. + , moduleExports :: M.Map ExtName Export + -- ^ All of the exports in a module. + , moduleReqs :: Reqs + -- ^ Module-level requirements. + , moduleHaskellName :: Maybe [String] + -- ^ The generated Haskell module name, underneath the + -- 'interfaceHaskellModuleBase'. If absent (by default), the 'moduleName' + -- is used. May be modified with 'moduleAddHaskellName'. + , moduleExceptionHandlers :: ExceptionHandlers + -- ^ Exceptions that all functions in the module may throw. + , moduleCallbacksThrow :: Maybe Bool + -- ^ Whether callbacks exported from the module support exceptions being + -- thrown during their execution. When present, this overrides + -- 'interfaceCallbacksThrow'. This maybe overridden by + -- 'Foreign.Hoppy.Generator.Spec.Callback.callbackThrows'. + , moduleAddendum :: Addendum + -- ^ The module's addendum. + } + +instance Eq Module where + (==) = (==) `on` moduleName + +instance Ord Module where + compare = compare `on` moduleName + +instance Show Module where + show m = concat [""] + +instance HasExports Module where + lookupExport name m = M.lookup name $ moduleExports m + +instance HasReqs Module where + getReqs = moduleReqs + setReqs reqs m = m { moduleReqs = reqs } + +instance HasAddendum Module where + getAddendum = moduleAddendum + setAddendum addendum m = m { moduleAddendum = addendum } + +instance HandlesExceptions Module where + getExceptionHandlers = moduleExceptionHandlers + modifyExceptionHandlers f m = m { moduleExceptionHandlers = f $ moduleExceptionHandlers m } + +-- | Creates an empty module, ready to be configured with 'moduleModify'. +makeModule :: String -- ^ 'moduleName' + -> String -- ^ 'moduleHppPath' + -> String -- ^ 'moduleCppPath' + -> Module +makeModule name hppPath cppPath = Module + { moduleName = name + , moduleHppPath = hppPath + , moduleCppPath = cppPath + , moduleExports = M.empty + , moduleReqs = mempty + , moduleHaskellName = Nothing + , moduleExceptionHandlers = mempty + , moduleCallbacksThrow = Nothing + , moduleAddendum = mempty + } + +-- | Extends a module. To be used with the module state-monad actions in this +-- package. +moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module +moduleModify = flip execStateT + +-- | Same as 'moduleModify', but calls 'error' in the case of failure, which is +-- okay in for a generator which would abort in this case anyway. +moduleModify' :: HasCallStack => Module -> StateT Module (Either String) () -> Module +moduleModify' m action = case moduleModify m action of + Left errorMsg -> + error $ concat + ["moduleModify' failed to modify ", show m, ": ", errorMsg] + Right m' -> m' + +-- | Replaces a module's 'moduleHppPath'. +moduleSetHppPath :: MonadState Module m => String -> m () +moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path } + +-- | Replaces a module's 'moduleCppPath'. +moduleSetCppPath :: MonadState Module m => String -> m () +moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path } + +-- | Adds exports to a module. An export must only be added to any module at +-- most once, and must not be added to multiple modules. +moduleAddExports :: (MonadError String m, MonadState Module m) => [Export] -> m () +moduleAddExports exports = do + m <- get + let existingExports = moduleExports m + newExports = M.fromList $ map (getPrimaryExtName &&& id) exports + duplicateNames = (S.intersection `on` M.keysSet) existingExports newExports + if S.null duplicateNames + then put m { moduleExports = existingExports `mappend` newExports } + else throwError $ concat + ["moduleAddExports: ", show m, " defines external names multiple times: ", + show duplicateNames] + +-- | Changes a module's 'moduleHaskellName' from the default. This can only be +-- called once on a module. +moduleAddHaskellName :: (MonadError String m, MonadState Module m) => [String] -> m () +moduleAddHaskellName name = do + m <- get + case moduleHaskellName m of + Nothing -> put m { moduleHaskellName = Just name } + Just name' -> + throwError $ concat + ["moduleAddHaskellName: ", show m, " already has Haskell name ", + show name', "; trying to add name ", show name, "."] + +-- | Changes 'Foreign.Hoppy.Generator.Spec.Callback.callbackThrows' for all +-- callbacks in a module that don't have it set explicitly. +moduleSetCallbacksThrow :: MonadState Module m => Maybe Bool -> m () +moduleSetCallbacksThrow b = modify $ \m -> m { moduleCallbacksThrow = b } + +-- | A set of requirements of needed to use an identifier in C++ (function, +-- type, etc.), via a set of 'Include's. The monoid instance has 'mempty' as an +-- empty set of includes, and 'mappend' unions two include sets. +newtype Reqs = Reqs + { reqsIncludes :: S.Set Include + -- ^ The includes specified by a 'Reqs'. + } deriving (Show) + +instance Sem.Semigroup Reqs where + (<>) (Reqs incl) (Reqs incl') = Reqs $ mappend incl incl' + +instance Monoid Reqs where + mempty = Reqs mempty + + mappend = (<>) + + mconcat reqs = Reqs $ mconcat $ map reqsIncludes reqs + +-- | Creates a 'Reqs' that contains the given include. +reqInclude :: Include -> Reqs +reqInclude include = mempty { reqsIncludes = S.singleton include } + +-- | Contains the data types for bindings to C++ entities: +-- 'Foreign.Hoppy.Generator.Spec.Function.Function', +-- 'Foreign.Hoppy.Generator.Spec.Class.Class', etc. Use 'addReqs' or +-- 'addReqIncludes' to specify requirements for these entities, e.g. header +-- files that must be included in order to access the underlying entities that +-- are being bound. + +-- | C++ types that have requirements in order to use them in generated +-- bindings. +class HasReqs a where + {-# MINIMAL getReqs, (setReqs | modifyReqs) #-} + + -- | Returns an object's requirements. + getReqs :: a -> Reqs + + -- | Replaces an object's requirements with new ones. + setReqs :: Reqs -> a -> a + setReqs = modifyReqs . const + + -- | Modifies an object's requirements. + modifyReqs :: (Reqs -> Reqs) -> a -> a + modifyReqs f x = setReqs (f $ getReqs x) x + +-- | Adds to a object's requirements. +addReqs :: HasReqs a => Reqs -> a -> a +addReqs reqs = modifyReqs $ mappend reqs + +-- | Adds a list of includes to the requirements of an object. +addReqIncludes :: HasReqs a => [Include] -> a -> a +addReqIncludes includes = + modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes } + +-- | An external name is a string that generated bindings use to uniquely +-- identify an object at runtime. An external name must start with an +-- alphabetic character, and may only contain alphanumeric characters and @'_'@. +-- You are free to use whatever naming style you like; case conversions will be +-- performed automatically when required. Hoppy does make use of some +-- conventions though, for example with 'Operator's and in the provided bindings +-- for the C++ standard library. +-- +-- External names must be unique within an interface. They may not be reused +-- between modules. This assumption is used for symbol naming in compiled +-- shared objects and to freely import modules in Haskell bindings. +newtype ExtName = ExtName + { fromExtName :: String + -- ^ Returns the string an an 'ExtName' contains. + } deriving (Eq, Sem.Semigroup, Monoid, Ord) + +instance Show ExtName where + show extName = concat ["$\"", fromExtName extName, "\"$"] + +-- | Creates an 'ExtName' that contains the given string, erroring if the string +-- is an invalid 'ExtName'. +toExtName :: HasCallStack => String -> ExtName +toExtName str = case str of + -- Keep this logic in sync with isValidExtName. + [] -> error "An ExtName cannot be empty." + _ -> if isValidExtName str + then ExtName str + else error $ + "An ExtName must start with a letter and only contain letters, numbers, and '_': " ++ + show str + +-- | Returns true if the given string is represents a valid 'ExtName'. +isValidExtName :: String -> Bool +isValidExtName str = case str of + -- Keep this logic in sync with toExtName. + [] -> False + c:cs -> isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs + +-- | Generates an 'ExtName' from an 'Identifier', if the given name is absent. +extNameOrIdentifier :: HasCallStack => Identifier -> Maybe ExtName -> ExtName +extNameOrIdentifier identifier = fromMaybe $ case identifierParts identifier of + [] -> error "extNameOrIdentifier: Invalid empty identifier." + parts -> toExtName $ idPartBase $ last parts + +-- | Generates an 'ExtName' from an @'FnName' 'Identifier'@, if the given name +-- is absent. +extNameOrFnIdentifier :: HasCallStack => FnName Identifier -> Maybe ExtName -> ExtName +extNameOrFnIdentifier name = + fromMaybe $ case name of + FnName identifier -> case identifierParts identifier of + [] -> error "extNameOrFnIdentifier: Empty idenfitier." + parts -> toExtName $ idPartBase $ last parts + FnOp op -> operatorPreferredExtName op + +-- | Generates an 'ExtName' from a string, if the given name is absent. +extNameOrString :: String -> Maybe ExtName -> ExtName +extNameOrString str = fromMaybe $ toExtName str + +-- | Types that have an external name, and also optionally have nested entities +-- with external names as well. See 'getAllExtNames'. +class HasExtNames a where + -- | Returns the external name by which a given entity is referenced. + getPrimaryExtName :: a -> ExtName + + -- | Returns external names nested within the given entity. Does not include + -- the primary external name. + getNestedExtNames :: a -> [ExtName] + getNestedExtNames _ = [] + +-- | Returns a list of all of the external names an entity contains. This +-- combines both 'getPrimaryExtName' and 'getNestedExtNames'. +getAllExtNames :: HasExtNames a => a -> [ExtName] +getAllExtNames x = getPrimaryExtName x : getNestedExtNames x + +-- | The C++ name of a function or method. +data FnName name = + FnName name + -- ^ A regular, \"alphanumeric\" name. The exact type depends on what kind of + -- object is being named. + | FnOp Operator + -- ^ An operator name. + deriving (Eq, Ord) + +instance Show name => Show (FnName name) where + show (FnName name) = concat [""] + show (FnOp op) = concat [""] + +-- | Enables implementing automatic conversions to a @'FnName' t@. +class IsFnName t a where + toFnName :: a -> FnName t + +instance IsFnName t (FnName t) where + toFnName = id + +instance IsFnName t t where + toFnName = FnName + +instance IsFnName t Operator where + toFnName = FnOp + +-- | Overloadable C++ operators. +data Operator = + OpCall -- ^ @x(...)@ + | OpComma -- ^ @x, y@ + | OpAssign -- ^ @x = y@ + | OpArray -- ^ @x[y]@ + | OpDeref -- ^ @*x@ + | OpAddress -- ^ @&x@ + | OpAdd -- ^ @x + y@ + | OpAddAssign -- ^ @x += y@ + | OpSubtract -- ^ @x - y@ + | OpSubtractAssign -- ^ @x -= y@ + | OpMultiply -- ^ @x * y@ + | OpMultiplyAssign -- ^ @x *= y@ + | OpDivide -- ^ @x / y@ + | OpDivideAssign -- ^ @x /= y@ + | OpModulo -- ^ @x % y@ + | OpModuloAssign -- ^ @x %= y@ + | OpPlus -- ^ @+x@ + | OpMinus -- ^ @-x@ + | OpIncPre -- ^ @++x@ + | OpIncPost -- ^ @x++@ + | OpDecPre -- ^ @--x@ + | OpDecPost -- ^ @x--@ + | OpEq -- ^ @x == y@ + | OpNe -- ^ @x != y@ + | OpLt -- ^ @x < y@ + | OpLe -- ^ @x <= y@ + | OpGt -- ^ @x > y@ + | OpGe -- ^ @x >= y@ + | OpNot -- ^ @!x@ + | OpAnd -- ^ @x && y@ + | OpOr -- ^ @x || y@ + | OpBitNot -- ^ @~x@ + | OpBitAnd -- ^ @x & y@ + | OpBitAndAssign -- ^ @x &= y@ + | OpBitOr -- ^ @x | y@ + | OpBitOrAssign -- ^ @x |= y@ + | OpBitXor -- ^ @x ^ y@ + | OpBitXorAssign -- ^ @x ^= y@ + | OpShl -- ^ @x << y@ + | OpShlAssign -- ^ @x <<= y@ + | OpShr -- ^ @x >> y@ + | OpShrAssign -- ^ @x >>= y@ + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | The arity and syntax of an operator. +data OperatorType = + UnaryPrefixOperator String -- ^ Prefix unary operators. Examples: @!x@, @*x@, @++x@. + | UnaryPostfixOperator String -- ^ Postfix unary operators. Examples: @x--, x++@. + | BinaryOperator String -- ^ Infix binary operators. Examples: @x * y@, @x >>= y@. + | CallOperator -- ^ @x(...)@ with arbitrary arity. + | ArrayOperator -- ^ @x[y]@, a binary operator with non-infix syntax. + +data OperatorInfo = OperatorInfo + { operatorPreferredExtName'' :: ExtName + , operatorType' :: OperatorType + } + +makeOperatorInfo :: String -> OperatorType -> OperatorInfo +makeOperatorInfo = OperatorInfo . toExtName + +-- | Returns a conventional string to use for the 'ExtName' of an operator. +operatorPreferredExtName :: HasCallStack => Operator -> ExtName +operatorPreferredExtName op = case M.lookup op operatorInfo of + Just info -> operatorPreferredExtName'' info + Nothing -> + error $ concat + ["operatorPreferredExtName: Internal error, missing info for operator ", show op, "."] + +-- | Returns a conventional name for an operator, as with +-- 'operatorPreferredExtName', but as a string. +operatorPreferredExtName' :: Operator -> String +operatorPreferredExtName' = fromExtName . operatorPreferredExtName + +-- | Returns the type of an operator. +operatorType :: HasCallStack => Operator -> OperatorType +operatorType op = case M.lookup op operatorInfo of + Just info -> operatorType' info + Nothing -> + error $ concat + ["operatorType: Internal error, missing info for operator ", show op, "."] + +-- | Metadata for operators. +-- +-- TODO Test out this missing data. +operatorInfo :: M.Map Operator OperatorInfo +operatorInfo = + let input = + [ (OpCall, makeOperatorInfo "CALL" CallOperator) + , (OpComma, makeOperatorInfo "COMMA" $ BinaryOperator ",") + , (OpAssign, makeOperatorInfo "ASSIGN" $ BinaryOperator "=") + , (OpArray, makeOperatorInfo "ARRAY" ArrayOperator) + , (OpDeref, makeOperatorInfo "DEREF" $ UnaryPrefixOperator "*") + , (OpAddress, makeOperatorInfo "ADDRESS" $ UnaryPrefixOperator "&") + , (OpAdd, makeOperatorInfo "ADD" $ BinaryOperator "+") + , (OpAddAssign, makeOperatorInfo "ADDA" $ BinaryOperator "+=") + , (OpSubtract, makeOperatorInfo "SUB" $ BinaryOperator "-") + , (OpSubtractAssign, makeOperatorInfo "SUBA" $ BinaryOperator "-=") + , (OpMultiply, makeOperatorInfo "MUL" $ BinaryOperator "*") + , (OpMultiplyAssign, makeOperatorInfo "MULA" $ BinaryOperator "*=") + , (OpDivide, makeOperatorInfo "DIV" $ BinaryOperator "/") + , (OpDivideAssign, makeOperatorInfo "DIVA" $ BinaryOperator "/=") + , (OpModulo, makeOperatorInfo "MOD" $ BinaryOperator "%") + , (OpModuloAssign, makeOperatorInfo "MODA" $ BinaryOperator "%=") + , (OpPlus, makeOperatorInfo "PLUS" $ UnaryPrefixOperator "+") + , (OpMinus, makeOperatorInfo "NEG" $ UnaryPrefixOperator "-") + , (OpIncPre, makeOperatorInfo "INC" $ UnaryPrefixOperator "++") + , (OpIncPost, makeOperatorInfo "INCPOST" $ UnaryPostfixOperator "++") + , (OpDecPre, makeOperatorInfo "DEC" $ UnaryPrefixOperator "--") + , (OpDecPost, makeOperatorInfo "DECPOST" $ UnaryPostfixOperator "--") + , (OpEq, makeOperatorInfo "EQ" $ BinaryOperator "==") + , (OpNe, makeOperatorInfo "NE" $ BinaryOperator "!=") + , (OpLt, makeOperatorInfo "LT" $ BinaryOperator "<") + , (OpLe, makeOperatorInfo "LE" $ BinaryOperator "<=") + , (OpGt, makeOperatorInfo "GT" $ BinaryOperator ">") + , (OpGe, makeOperatorInfo "GE" $ BinaryOperator ">=") + , (OpNot, makeOperatorInfo "NOT" $ UnaryPrefixOperator "!") + , (OpAnd, makeOperatorInfo "AND" $ BinaryOperator "&&") + , (OpOr, makeOperatorInfo "OR" $ BinaryOperator "||") + , (OpBitNot, makeOperatorInfo "BNOT" $ UnaryPrefixOperator "~") + , (OpBitAnd, makeOperatorInfo "BAND" $ BinaryOperator "&") + , (OpBitAndAssign, makeOperatorInfo "BANDA" $ BinaryOperator "&=") + , (OpBitOr, makeOperatorInfo "BOR" $ BinaryOperator "|") + , (OpBitOrAssign, makeOperatorInfo "BORA" $ BinaryOperator "|=") + , (OpBitXor, makeOperatorInfo "BXOR" $ BinaryOperator "^") + , (OpBitXorAssign, makeOperatorInfo "BXORA" $ BinaryOperator "^=") + , (OpShl, makeOperatorInfo "SHL" $ BinaryOperator "<<") + , (OpShlAssign, makeOperatorInfo "SHLA" $ BinaryOperator "<<=") + , (OpShr, makeOperatorInfo "SHR" $ BinaryOperator ">>") + , (OpShrAssign, makeOperatorInfo "SHR" $ BinaryOperator ">>=") + ] + in if map fst input == [minBound..] + then M.fromList input + else error "operatorInfo: Operator info list is out of sync with Operator data type." + +-- | Types that contain 'Export's that can be looked up by their 'ExtName's. +class HasExports a where + -- | Looks up the 'Export' for an 'ExtName' in the given object. + lookupExport :: ExtName -> a -> Maybe Export + +-- | A path to some C++ object, including namespaces. An identifier consists of +-- multiple parts separated by @\"::\"@. Each part has a name string followed +-- by an optional template argument list, where each argument gets rendered from +-- a 'Type' (non-type arguments for template metaprogramming are not supported). +-- +-- The 'Monoid' instance inserts a @::@ between joined identifiers. Usually an +-- identifier needs to contain at least one part, so 'mempty' is an invalid +-- argument to many functions in Hoppy, but it is useful as a base case for +-- appending. +newtype Identifier = Identifier + { identifierParts :: [IdPart] + -- ^ The separate parts of the identifier, between @::@s. + } deriving (Eq, Monoid, Sem.Semigroup) + +instance Show Identifier where + show identifier = + (\wordList -> concat $ ""]) $ + intersperse "::" $ + map (\part -> case idPartArgs part of + Nothing -> idPartBase part + Just args -> + concat $ + idPartBase part : "<" : + intersperse ", " (map show args) ++ [">"]) $ + identifierParts identifier + +-- | A single component of an 'Identifier', between @::@s. +data IdPart = IdPart + { idPartBase :: String + -- ^ The name within the enclosing scope. + , idPartArgs :: Maybe [Type] + -- ^ Template arguments, if present. + } deriving (Eq, Show) + +-- | Creates an identifier from a collection of 'IdPart's, with @::@s between. +makeIdentifier :: [IdPart] -> Identifier +makeIdentifier = Identifier + +-- | Creates an object representing one component of an identifier. +makeIdPart :: String -> Maybe [Type] -> IdPart +makeIdPart = IdPart + +-- | Creates a identifier of the form @a@, without any namespace operators +-- (@::@). +ident :: String -> Identifier +ident a = Identifier [IdPart a Nothing] + +-- | Creates an identifier of the form @a1::a2::...::aN@. +ident' :: [String] -> Identifier +ident' = Identifier . map (\x -> IdPart { idPartBase = x, idPartArgs = Nothing }) + +-- | Creates an identifier of the form @a::b@. +ident1 :: String -> String -> Identifier +ident1 a b = ident' [a, b] + +-- | Creates an identifier of the form @a::b::c@. +ident2 :: String -> String -> String -> Identifier +ident2 a b c = ident' [a, b, c] + +-- | Creates an identifier of the form @a::b::c::d@. +ident3 :: String -> String -> String -> String -> Identifier +ident3 a b c d = ident' [a, b, c, d] + +-- | Creates an identifier of the form @a::b::c::d::e@. +ident4 :: String -> String -> String -> String -> String -> Identifier +ident4 a b c d e = ident' [a, b, c, d, e] + +-- | Creates an identifier of the form @a::b::c::d::e::f@. +ident5 :: String -> String -> String -> String -> String -> String -> Identifier +ident5 a b c d e f = ident' [a, b, c, d, e, f] + +-- | Creates an identifier of the form @a\<...\>@. +identT :: String -> [Type] -> Identifier +identT a ts = Identifier [IdPart a $ Just ts] + +-- | Creates an identifier with arbitrary many templated and non-templated +-- parts. +identT' :: [(String, Maybe [Type])] -> Identifier +identT' = Identifier . map (uncurry IdPart) + +-- | Creates an identifier of the form @a::b\<...\>@. +ident1T :: String -> String -> [Type] -> Identifier +ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts] + +-- | Creates an identifier of the form @a::b::c\<...\>@. +ident2T :: String -> String -> String -> [Type] -> Identifier +ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts] + +-- | Creates an identifier of the form @a::b::c::d\<...\>@. +ident3T :: String -> String -> String -> String -> [Type] -> Identifier +ident3T a b c d ts = + Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, + IdPart d $ Just ts] + +-- | Creates an identifier of the form @a::b::c::d::e\<...\>@. +ident4T :: String -> String -> String -> String -> String -> [Type] -> Identifier +ident4T a b c d e ts = + Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, + IdPart d Nothing, IdPart e $ Just ts] + +-- | Creates an identifier of the form @a::b::c::d::e::f\<...\>@. +ident5T :: String -> String -> String -> String -> String -> String -> [Type] -> Identifier +ident5T a b c d e f ts = + Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, + IdPart d Nothing, IdPart e Nothing, IdPart f $ Just ts] + +-- | Instances of this typeclass are C++ entities that Hoppy can expose to +-- foreign languages: functions, classes, global variables, etc. 'Interface's +-- are largely composed of exports (grouped into modules). Hoppy uses this +-- interface to perform code generation for each entity. +class (HasAddendum a, HasExtNames a, HasReqs a, Typeable a, Show a) => Exportable a where + -- | Wraps an exportable object in an existential data type. + -- + -- The default instance is just @toExport = 'Export'@, which does not need to + -- be overridden in general. + toExport :: a -> Export + toExport = Export + + -- | Attempts to cast an exportable object to a specific type, pulling off + -- 'Export' wrappers as necessary. + -- + -- The default @castExport = 'cast'@ is fine. + castExport :: (Typeable a, Exportable b, Typeable b) => a -> Maybe b + castExport = cast + + -- | Generates the C++ side of the binding for an entity. + -- + -- For an entity, Hoppy invokes this function once with 'LC.SayHeader' when + -- generating the header file for a module, and once with 'LC.SaySource' when + -- generating the corresponding source file. + sayExportCpp :: LC.SayExportMode -> a -> LC.Generator () + + -- | Generates the Haskell side of the binding for an entity. + -- + -- For an entity, Hoppy invokes this function once with + -- 'LH.SayExportForeignImports' when it is time to emit foreign imports, and + -- once with 'LH.SayExportDecls' when it is time to generate Haskell binding + -- code later in the module. Hoppy may also call the function with + -- 'LH.SayExportBoot', if necessary. + -- + -- See 'LH.SayExportMode'. + sayExportHaskell :: LH.SayExportMode -> a -> LH.Generator () + + -- | If the export is backed by an C++ enum, then this returns known + -- structural information about the enum. This provides information to the + -- \"evaluate enums\" hook so that Hoppy can determine enum values on its own. + -- + -- By default, this returns @Nothing@. + -- + -- See 'Hooks'. + getExportEnumInfo :: a -> Maybe EnumInfo + getExportEnumInfo _ = Nothing + + -- | If the export is backed by a C++ class that is marked as supporting + -- exceptions, then this returns the class definition. + -- + -- By default, this returns @Nothing@. + getExportExceptionClass :: a -> Maybe Class + getExportExceptionClass _ = Nothing + +-- | Specifies some C++ object (function or class) to give access to. +data Export = forall a. Exportable a => Export a + +instance HasAddendum Export where + getAddendum (Export e) = getAddendum e + setAddendum a (Export e) = Export $ setAddendum a e + modifyAddendum f (Export e) = Export $ modifyAddendum f e + +instance HasExtNames Export where + getPrimaryExtName (Export e) = getPrimaryExtName e + getNestedExtNames (Export e) = getNestedExtNames e + +instance HasReqs Export where + getReqs (Export e) = getReqs e + setReqs reqs (Export e) = Export $ setReqs reqs e + modifyReqs f (Export e) = Export $ modifyReqs f e + +instance Exportable Export where + toExport = id + + castExport (Export e) = castExport e + + sayExportCpp sayBody (Export e) = sayExportCpp sayBody e + + sayExportHaskell mode (Export e) = sayExportHaskell mode e + + getExportEnumInfo (Export e) = getExportEnumInfo e + + getExportExceptionClass (Export e) = getExportExceptionClass e + +instance Show Export where + show (Export e) = "" + +-- | A concrete C++ type. Use the bindings in "Foreign.Hoppy.Generator.Types" +-- for values of this type; these data constructors are subject to change +-- without notice. +data Type = + Internal_TVoid + | Internal_TPtr Type + | Internal_TRef Type + | Internal_TFn [Parameter] Type + | Internal_TObj Class + | Internal_TObjToHeap Class + | Internal_TToGc Type + | Internal_TManual ConversionSpec + | Internal_TConst Type + -- When changing the declarations here, be sure to update the Eq instance. + deriving (Show) + +instance Eq Type where + Internal_TVoid == Internal_TVoid = True + (Internal_TPtr t) == (Internal_TPtr t') = t == t' + (Internal_TRef t) == (Internal_TRef t') = t == t' + (Internal_TFn ps r) == (Internal_TFn ps' r') = + (and $ zipWith ((==) `on` parameterType) ps ps') && r == r' + (Internal_TObj cls) == (Internal_TObj cls') = cls == cls' + (Internal_TObjToHeap cls) == (Internal_TObjToHeap cls') = cls == cls' + (Internal_TToGc t) == (Internal_TToGc t') = t == t' + (Internal_TManual s) == (Internal_TManual s') = s == s' + (Internal_TConst t) == (Internal_TConst t') = t == t' + _ == _ = False + +-- | Canonicalizes a 'Type' without changing its meaning. Multiple nested +-- 'Internal_TConst's are collapsed into a single one. +normalizeType :: Type -> Type +normalizeType t = case t of + Internal_TVoid -> t + Internal_TPtr t' -> Internal_TPtr $ normalizeType t' + Internal_TRef t' -> Internal_TRef $ normalizeType t' + Internal_TFn params retType -> + Internal_TFn (map (onParameterType normalizeType) params) $ normalizeType retType + Internal_TObj _ -> t + Internal_TObjToHeap _ -> t + Internal_TToGc _ -> t + Internal_TManual _ -> t + Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t' + Internal_TConst _ -> t + +-- | Strips leading 'Internal_TConst's off of a type. +stripConst :: Type -> Type +stripConst t = case t of + Internal_TConst t' -> stripConst t' + _ -> t + +-- | Whether or not @const@ is applied to an entity. +data Constness = Nonconst | Const + deriving (Bounded, Enum, Eq, Show) + +-- | Returns the opposite constness value. +constNegate :: Constness -> Constness +constNegate Nonconst = Const +constNegate Const = Nonconst + +-- | Whether or not a function may cause side-effects. +-- +-- Haskell bindings for pure functions will not be in 'IO', and calls to pure +-- functions will be executed non-strictly. Calls to impure functions will +-- execute in the IO monad. +-- +-- Member functions for mutable classes should not be made pure, because it is +-- difficult in general to control when the call will be made. +data Purity = Nonpure -- ^ Side-affects are possible. + | Pure -- ^ Side-affects will not happen. + deriving (Eq, Show) + +-- | A parameter to a function, including a type and an optional name. A name +-- can be conveniently associated with a type with the @('~:')@ operator. +-- +-- Two @Parameter@s are equal if their types are equal. +data Parameter = Parameter + { parameterType :: Type + -- ^ The parameter's data type. + , parameterName :: Maybe String + -- ^ An optional variable name to describe the parameter. This name should + -- follow the same rules as 'ExtName' for its contents. + } deriving (Show) + +-- | Objects that can be coerced to function parameter definitions. +class Show a => IsParameter a where + toParameter :: a -> Parameter + +instance IsParameter Parameter where + toParameter = id + +instance IsParameter Type where + toParameter t = + Parameter + { parameterType = t + , parameterName = Nothing + } + +onParameterType :: (Type -> Type) -> (Parameter -> Parameter) +onParameterType f p = p { parameterType = f $ parameterType p } + +-- | An empty parameter list. This should be used instead of a literal @[]@ +-- when declaring an empty parameter list, because in the context of +-- @'IsParameter' a => [a]@, the empty list is ambiguously typed, even though it +-- doesn't matter which instance is selected. +np :: [Parameter] +np = [] + +-- | Converts a list of parameter-like objects to parameters. +toParameters :: IsParameter a => [a] -> [Parameter] +toParameters = map toParameter + +-- | Associates a name string with a type to create a 'Parameter' that +-- can be given as a function or method parameter, instead of a raw 'Type'. The +-- name given here will be included as documentation in the generated code. +-- +-- An empty string given for the name means not to associate a name with the +-- parameter. This is useful to leave some parameters unnamed in a parameter +-- list while naming other parameters, since the list must either contain all +-- 'Type's or all 'Parameter's. +(~:) :: IsParameter a => String -> a -> Parameter +(~:) name param = + (toParameter param) { parameterName = if null name then Nothing else Just name } +infixr 0 ~: + +-- | Defines the process for converting a value in one direction between C++ and +-- a foreign language. The type parameter varies depending on the actual +-- conversion being defined. +data ConversionMethod c = + ConversionUnsupported + -- ^ The conversion is unsupported. If part of an interface depends on + -- performing this conversion, code generation will fail. + | BinaryCompatible + -- ^ The input value and its corresponding output have the same binary + -- representation in memory, and require no explicit conversion. Numeric + -- types may use this conversion method. + | CustomConversion c + -- ^ Conversion requires a custom process as specified by the argument. + -- + -- TODO Split into pure (let) vs nonpure (<-)? + deriving (Show) + +-- | The root data type for specifying how conversions happen between C++ and foreign +-- values. +-- +-- The @Cpp@ component of this data structure specifies a C++ type, and +-- conversions between it and something that can be marshalled over a C FFI +-- layer, if such a conversion is possible in each direction. +-- +-- Each foreign language has its own component that must be specified in order +-- for types using this specification to be usable in that language. +data ConversionSpec = ConversionSpec + { conversionSpecName :: String + -- ^ An identifying name, used for rendering in e.g. error messages. + , conversionSpecCpp :: ConversionSpecCpp + -- ^ Fundamental information about the C++ type. + , conversionSpecHaskell :: Maybe ConversionSpecHaskell + -- ^ A specification for how values can be used in Haskell. + } + +instance Eq ConversionSpec where + (==) = (==) `on` conversionSpecName + +instance Show ConversionSpec where + show x = "" + +-- | Creates a 'ConversionSpec' from an identifying name and a specification of +-- the C++ conversion behaviour. By default, no foreign language conversion +-- behaviour is configured. For Haskell, this should be done by using +-- 'makeConversionSpecHaskell' to specify behaviour, then writing that to the +-- 'conversionSpecHaskell' field of the 'ConversionSpec' returned here. +makeConversionSpec :: + String -- ^ 'conversionSpecName' + -> ConversionSpecCpp -- ^ 'conversionSpecCpp' + -> ConversionSpec +makeConversionSpec name cppSpec = + ConversionSpec + { conversionSpecName = name + , conversionSpecCpp = cppSpec + , conversionSpecHaskell = Nothing + } + +-- | For a 'ConversionSpec', defines the C++ type and conversions to and from a +-- C FFI layer. +-- +-- Prefer 'makeConversionSpecCpp' to using this data constructor directly. +-- +-- 'conversionSpecCppName' specifies the C++ type of the conversion. This will +-- be the type that is passed over the C FFI as well, unless +-- 'conversionSpecCppConversionType' overrides it. +-- 'conversionSpecCppConversionToCppExpr' and +-- 'conversionSpecCppConversionFromCppExpr' may define custom code generation +-- for passing values over the FFI. +data ConversionSpecCpp = ConversionSpecCpp + { conversionSpecCppName :: String + -- ^ The name of the C++ type. May identify a primitive C++ type such as + -- @\"unsigned int\"@, or a more complex type like + -- @std::list\@. + + , conversionSpecCppReqs :: LC.Generator Reqs + -- ^ Computes requirements to refer to the C++ type. Being in the generator + -- monad, this may use its environment, but should not emit code or 'Reqs' + -- to the generator directly. + + , conversionSpecCppConversionType :: LC.Generator (Maybe Type) + -- ^ Specifies the type that will be passed over the C FFI. + -- + -- If absent (default), then the type named by 'conversionSpecCppName' is + -- also used for marshalling to foreign languages. + -- + -- If present, this represents a type distinct from 'conversionSpecCppName' + -- that will be exchanged across the FFI boundary. In this case, you may + -- also want to define one or both of 'conversionSpecCppConversionToCppExpr' + -- and 'conversionSpecCppConversionFromCppExpr'. + -- + -- This is a monadic value so that it has access to the generator's + -- environment. The action should not add imports or emit code. + + , conversionSpecCppConversionToCppExpr :: + Maybe (LC.Generator () -> Maybe (LC.Generator ()) -> LC.Generator ()) + -- ^ This controls behaviour for receiving a value passed into C++ over the + -- FFI. Specifically, this powers the @ConversionSpec@ being used as + -- 'Foreign.Hoppy.Generator.Spec.Function.Function' arguments and + -- 'Foreign.Hoppy.Generator.Spec.Callback.Callback' return values. + -- + -- When absent (default), generated code assumes that it can implicitly + -- convert a value passed over the FFI from the C FFI type (see + -- 'conversionSpecCppConversionType') to the C++ type + -- (i.e. 'conversionSpecCppName'). When the former is absent, this is + -- always fine. + -- + -- When present, this provides custom conversion behaviour for receiving a + -- value passed into C++ over the FFI. The function should generate C++ + -- code to convert a value from the type passed over the C FFI into the + -- actual C++ type. + -- + -- This is a function of the form: + -- + -- > \emitFromExpr maybeEmitToVar -> ... + -- + -- If the function's second argument is present, then the function should + -- emit a variable declaration for that name, created from the expression + -- emitted by the first argument. + -- + -- If the function's second argument is absent, then the function should + -- emit an expression that converts the expression emitted by the first + -- argument into the appropriate type. + -- + -- In both cases, the first generator argument should only be evaluated once + -- by the resulting C++ expression; it is not guaranteed to be pure. + + , conversionSpecCppConversionFromCppExpr :: + Maybe (LC.Generator () -> Maybe (LC.Generator ()) -> LC.Generator ()) + -- ^ This is the opposite of 'conversionSpecCppConversionToCppExpr'. This + -- being present enables custom conversion behaviour for passing a value + -- /out of/ C++ through the FFI. This powers the @ConversionSpec@ being + -- used as 'Foreign.Hoppy.Generator.Spec.Function.Function' return values + -- and 'Foreign.Hoppy.Generator.Spec.Callback.Callback' arguments. + } + +-- | Builds a 'ConversionSpecCpp' with a C++ type, with no conversions defined. +makeConversionSpecCpp :: String -> LC.Generator Reqs -> ConversionSpecCpp +makeConversionSpecCpp cppName cppReqs = + ConversionSpecCpp + { conversionSpecCppName = cppName + , conversionSpecCppReqs = cppReqs + , conversionSpecCppConversionType = return Nothing + , conversionSpecCppConversionToCppExpr = Nothing + , conversionSpecCppConversionFromCppExpr = Nothing + } + +-- | Controls how conversions between C++ values and Haskell values happen in +-- Haskell bindings. +-- +-- Prefer 'makeConversionSpecHaskell' to using this data constructor directly. +data ConversionSpecHaskell = ConversionSpecHaskell + { conversionSpecHaskellHsType :: LH.Generator HsType + -- ^ The type exposed to users of the Haskell side of a binding. Functions + -- that take one of these values as an argument will expect this type, and + -- functions returning one of these values will return this type. + -- + -- This type is wrapped in a generator in order to be able to specify any + -- necessary imports. This generator should not generate code or add + -- exports. + + , conversionSpecHaskellHsArgType :: Maybe (HsName -> LH.Generator HsQualType) + -- ^ If present, then for bindings for C++ functions that expect one of + -- these values as an argument, rather than taking a fixed concrete type + -- ('conversionSpecHaskellHsType'), this qualified type will be used + -- instead. The 'HsName' parameter receives a unique name from the + -- generator that can be used with 'Language.Haskell.Syntax.HsTyVar' like + -- so: + -- + -- > \name -> return $ HsQualType [...constraints...] (HsTyVar name) + -- + -- 'conversionSpecHaskellHsType' should satisfy this constraint, when + -- present. + -- + -- This type is wrapped in a generator in order to be able to specify any + -- necessary imports. This generator should not generate code or add + -- exports. + + , conversionSpecHaskellCType :: Maybe (LH.Generator HsType) + -- ^ If present, then rather than passing a value of native Haskell type + -- ('conversionSpecHaskellHsType') directly over the FFI, this is an + -- intermediate type that will be passed instead. This is needed any time + -- that the former type isn't a simple type that the FFI supports. + -- + -- 'conversionSpecHaskellToCppFn' and 'conversionSpecHaskellFromCppFn' + -- marshal values into and out of this type, respsectively. + -- + -- This type is wrapped in a generator in order to be able to specify any + -- necessary imports. This generator should not generate code or add + -- exports. + + , conversionSpecHaskellToCppFn :: ConversionMethod (LH.Generator ()) + -- ^ This defines how a Haskell value is passed to C++. If this is + -- 'CustomConversion', then 'conversionSpecHaskellCType' must be present, + -- and the generator should output a function that takes a value of type + -- 'conversionSpecHaskellHsType' and return a value of + -- 'conversionSpecHaskellCType'. + -- + -- If 'conversionSpecHaskellHsArgType' is present, then the function should + -- be able to accept that more general type instead. This is used for + -- bindings that call into C++ functions. This function is still + -- specialized to 'conversionSpecHaskellHsType' when generating code for + -- callback return values. + -- + -- The generator should output code and may add imports, but should not add + -- exports. + + , conversionSpecHaskellFromCppFn :: ConversionMethod (LH.Generator ()) + -- ^ This defines how a Haskell value is passed from C++. If this is + -- 'CustomConversion', then 'conversionSpecHaskellCType' must be present, + -- and the generator should output a function that takes a value of type + -- 'conversionSpecHaskellCType' and return a value of + -- 'conversionSpecHaskellHsType'. + -- + -- The generator should output code and may add imports, but should not add + -- exports. + } + +-- | Builds a 'ConversionSpecHaskell' with the mandatory parameters given. +makeConversionSpecHaskell :: + LH.Generator HsType -- ^ 'conversionSpecHaskellHsType' + -> Maybe (LH.Generator HsType) -- ^ 'conversionSpecHaskellCType' + -> ConversionMethod (LH.Generator ()) -- ^ 'conversionSpecHaskellToCppFn' + -> ConversionMethod (LH.Generator ()) -- ^ 'conversionSpecHaskellFromCppFn' + -> ConversionSpecHaskell +makeConversionSpecHaskell hsType cType toCppFn fromCppFn = + ConversionSpecHaskell + { conversionSpecHaskellHsType = hsType + , conversionSpecHaskellHsArgType = Nothing + , conversionSpecHaskellCType = cType + , conversionSpecHaskellToCppFn = toCppFn + , conversionSpecHaskellFromCppFn = fromCppFn + } + +-- | Information about the enum that has been completed beyond what the +-- interface definition provides, possibly by building actual C++ code. +data EvaluatedEnumData = EvaluatedEnumData + { evaluatedEnumType :: Type + -- ^ The numeric type that C++ uses to hold the enum's values, or an + -- equivalently-sized type. + , evaluatedEnumValueMap :: EvaluatedEnumValueMap + -- ^ Calculated values for all of the enum's entries. + } + +-- | Contains the numeric values for each of the entries in a C++ enum. +type EvaluatedEnumValueMap = M.Map [String] Integer + +-- | Each exception class has a unique exception ID. +newtype ExceptionId = ExceptionId + { getExceptionId :: Int -- ^ Internal. + } deriving (Eq, Show) + +-- | The exception ID that represents the catch-all type. +exceptionCatchAllId :: ExceptionId +exceptionCatchAllId = ExceptionId 1 + +-- | The lowest exception ID to be used for classes. +exceptionFirstFreeId :: Int +exceptionFirstFreeId = getExceptionId exceptionCatchAllId + 1 + +-- | Indicates the ability to handle a certain type of C++ exception. +data ExceptionHandler = + CatchClass Class + -- ^ Indicates that instances of the given class are handled (including + -- derived types). + | CatchAll + -- ^ Indicates that all C++ exceptions are handled, i.e. @catch (...)@. + deriving (Eq, Ord) + +-- | Represents a list of exception handlers to be used for a body of code. +-- Order is important; a 'CatchAll' will prevent all subsequent handlers from +-- being invoked. +newtype ExceptionHandlers = ExceptionHandlers + { exceptionHandlersList :: [ExceptionHandler] + -- ^ Extracts the list of exception handlers. + } + +instance Sem.Semigroup ExceptionHandlers where + (<>) e1 e2 = + ExceptionHandlers $ exceptionHandlersList e1 ++ exceptionHandlersList e2 + +instance Monoid ExceptionHandlers where + mempty = ExceptionHandlers [] + + mappend = (<>) + +-- | Types that can handle exceptions. +class HandlesExceptions a where + -- | Extracts the exception handlers for an object. + getExceptionHandlers :: a -> ExceptionHandlers + + -- | Modifies an object's exception handlers with a given function. + modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> a -> a + +-- | Appends additional exception handlers to an object. +handleExceptions :: HandlesExceptions a => [ExceptionHandler] -> a -> a +handleExceptions classes = + modifyExceptionHandlers $ mappend mempty { exceptionHandlersList = classes } + +-- | A literal piece of code that will be inserted into a generated source file +-- after the regular binding glue. The 'Monoid' instance concatenates code +-- (actions). +newtype Addendum = Addendum + { addendumHaskell :: LH.Generator () + -- ^ Code to be output into the Haskell binding. May also add imports and + -- exports. + } + +instance Sem.Semigroup Addendum where + (<>) (Addendum a) (Addendum b) = Addendum $ a >> b + +instance Monoid Addendum where + mempty = Addendum $ return () + mappend = (<>) + +-- | A typeclass for types that have an addendum. +class HasAddendum a where + {-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-} + + -- | Returns an object's addendum. + getAddendum :: a -> Addendum + + -- | Replaces and object's addendum with another. + setAddendum :: Addendum -> a -> a + setAddendum addendum = modifyAddendum $ const addendum + + -- | Modified an object's addendum. + modifyAddendum :: (Addendum -> Addendum) -> a -> a + modifyAddendum f x = setAddendum (f $ getAddendum x) x + +-- | Adds a Haskell addendum to an object. +addAddendumHaskell :: HasAddendum a => LH.Generator () -> a -> a +addAddendumHaskell gen = modifyAddendum $ \addendum -> + addendum `mappend` mempty { addendumHaskell = gen } + +-- | Structural information about a C++ enum. This is used when Hoppy is +-- evaluating enum data, see 'getExportEnumInfo'. +-- +-- See 'Foreign.Hoppy.Generator.Spec.Enum.CppEnum'. +data EnumInfo = EnumInfo + { enumInfoExtName :: ExtName + -- ^ The external name of the enum. + , enumInfoIdentifier :: Identifier + -- ^ The enum's identifier. + , enumInfoNumericType :: Maybe Type + -- ^ The enum's numeric type, if explicitly known to the bindings. This + -- does not need to be provided. If absent, then Hoppy will calculate the + -- enum's numeric type on its own, using a C++ compiler. If this is present + -- however, Hoppy will use it, and additionally validate it against what the + -- C++ compiler thinks, if validation is enabled (see + -- 'interfaceValidateEnumTypes'). + , enumInfoReqs :: Reqs + -- ^ Requirements for accessing the enum. + , enumInfoValues :: EnumValueMap + -- ^ The entries in the enum. + } + +-- | A list of words that comprise the name of an enum entry. Each string in +-- this list is treated as a distinct word for the purpose of performing case +-- conversion to create identifiers in foreign languages. These values are most +-- easily created from a C++ identifier using +-- 'Foreign.Hoppy.Generator.Util.splitIntoWords'. +type EnumEntryWords = [String] + +-- | Describes the entries in a C++ enum. +-- +-- Equality is defined as having the same 'enumValueMapValues'. +data EnumValueMap = EnumValueMap + { enumValueMapNames :: [EnumEntryWords] + -- ^ The names of all entries in the enum being generated, in the order + -- specified by the enum definition. These are the strings used to name + -- generated bindings. Each name is broken up into words. How the words + -- and get combined to make a name in a particular foreign language depends + -- on the language. + , enumValueMapForeignNames :: MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords + -- ^ Per-language renames of enum value entries. + , enumValueMapValues :: M.Map EnumEntryWords EnumValue + -- ^ A map specifying for each entry in 'enumValueMapNames', how to + -- determine the entry's numeric value. + } + +instance Eq EnumValueMap where + (==) = (==) `on` enumValueMapValues + +instance Show EnumValueMap where + show x = "" + +-- | Describes the value of an entry in a C++ enum. A numeric value may either +-- be provided manually, or if omitted, Hoppy can determine it automatically. +data EnumValue = + EnumValueManual Integer + -- ^ A manually specified numeric enum value. + | EnumValueAuto Identifier + -- ^ A numeric enum value that will be determined when the generator is run, + -- by means of compiling a C++ program. + deriving (Eq, Show) + +-- | Languages that Hoppy supports binding to. Currently this is only Haskell. +data ForeignLanguage = + Haskell -- ^ The Haskell language. + deriving (Eq, Ord, Show) + +-- | A value that may be overridden based on a 'ForeignLanguage'. +type WithForeignLanguageOverrides = WithOverrides ForeignLanguage + +-- | A map whose values may be overridden based on a 'ForeignLanguage'. +type MapWithForeignLanguageOverrides = MapWithOverrides ForeignLanguage + +-- | A collection of imports for a Haskell module. This is a monoid: import +-- Statements are merged to give the union of imported bindings. +-- +-- This structure supports two specific types of imports: +-- - @import Foo (...)@ +-- - @import qualified Foo as Bar@ +-- Imports with @as@ but without @qualified@, and @qualified@ imports with a +-- spec list, are not supported. This satisfies the needs of the code +-- generator, and keeps the merging logic simple. +data HsImportSet = HsImportSet + { getHsImportSet :: M.Map HsImportKey HsImportSpecs + -- ^ Returns the import set's internal map from module names to imported + -- bindings. + } deriving (Show) + +-- TODO Make HsImportSet back into a newtype when it doesn't involve listing out +-- its contents recursively in Base.hs-boot. + +instance Sem.Semigroup HsImportSet where + (<>) (HsImportSet m) (HsImportSet m') = + HsImportSet $ M.unionWith mergeImportSpecs m m' + +instance Monoid HsImportSet where + mempty = HsImportSet M.empty + + mappend = (<>) + + mconcat sets = + HsImportSet $ M.unionsWith mergeImportSpecs $ map getHsImportSet sets + +-- | Constructor for an import set. +makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet +makeHsImportSet = HsImportSet + +-- | Sets all of the import specifications in an import set to be +-- @{-#SOURCE#-}@ imports. +hsImportSetMakeSource :: HsImportSet -> HsImportSet +hsImportSetMakeSource (HsImportSet m) = + HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m + +-- | A Haskell module name. +type HsModuleName = String + +-- | References an occurrence of an import statement, under which bindings can +-- be imported. Only imported specs under equal 'HsImportKey's may be merged. +data HsImportKey = HsImportKey + { hsImportModule :: HsModuleName + , hsImportQualifiedName :: Maybe HsModuleName + } deriving (Eq, Ord, Show) + +-- | A specification of bindings to import from a module. If 'Nothing', then +-- the entire module is imported. If @'Just' 'M.empty'@, then only instances +-- are imported. +data HsImportSpecs = HsImportSpecs + { getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal) + , hsImportSource :: Bool + } deriving (Show) + +-- | Combines two 'HsImportSpecs's into one that imports everything that the two +-- did separately. +mergeImportSpecs :: HsImportSpecs -> HsImportSpecs -> HsImportSpecs +mergeImportSpecs (HsImportSpecs mm s) (HsImportSpecs mm' s') = + HsImportSpecs (liftM2 mergeMaps mm mm') (s || s') + where mergeMaps = M.unionWith mergeValues + mergeValues v v' = case (v, v') of + (HsImportValAll, _) -> HsImportValAll + (_, HsImportValAll) -> HsImportValAll + (HsImportValSome x, HsImportValSome x') -> HsImportValSome $ x ++ x' + (x@(HsImportValSome _), _) -> x + (_, x@(HsImportValSome _)) -> x + (HsImportVal, HsImportVal) -> HsImportVal + +-- | An identifier that can be imported from a module. Symbols may be used here +-- when surrounded by parentheses. Examples are @\"fmap\"@ and @\"(++)\"@. +type HsImportName = String + +-- | Specifies how a name is imported. +data HsImportVal = + HsImportVal + -- ^ The name is imported, and nothing underneath it is. + | HsImportValSome [HsImportName] + -- ^ The name is imported, as are specific names underneath it. This is a + -- @X (a, b, c)@ import. + | HsImportValAll + -- ^ The name is imported, along with all names underneath it. This is a @X + -- (..)@ import. + deriving (Show) + +-- | An import for the entire contents of a Haskell module. +hsWholeModuleImport :: HsModuleName -> HsImportSet +hsWholeModuleImport modName = + HsImportSet $ M.singleton (HsImportKey modName Nothing) $ + HsImportSpecs Nothing False + +-- | A qualified import of a Haskell module. +hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet +hsQualifiedImport modName qualifiedName = + HsImportSet $ M.singleton (HsImportKey modName $ Just qualifiedName) $ + HsImportSpecs Nothing False + +-- | An import of a single name from a Haskell module. +hsImport1 :: HsModuleName -> HsImportName -> HsImportSet +hsImport1 modName valueName = hsImport1' modName valueName HsImportVal + +-- | A detailed import of a single name from a Haskell module. +hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet +hsImport1' modName valueName valueType = + HsImportSet $ M.singleton (HsImportKey modName Nothing) $ + HsImportSpecs (Just $ M.singleton valueName valueType) False + +-- | An import of multiple names from a Haskell module. +hsImports :: HsModuleName -> [HsImportName] -> HsImportSet +hsImports modName names = + hsImports' modName $ map (\name -> (name, HsImportVal)) names + +-- | A detailed import of multiple names from a Haskell module. +hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet +hsImports' modName values = + HsImportSet $ M.singleton (HsImportKey modName Nothing) $ + HsImportSpecs (Just $ M.fromList values) False + +-- | Imports "Data.Bits" qualified as @HoppyDB@. +hsImportForBits :: HsImportSet +hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB" + +-- | Imports "Control.Exception" qualified as @HoppyCE@. +hsImportForException :: HsImportSet +hsImportForException = hsQualifiedImport "Control.Exception" "HoppyCE" + +-- | Imports "Data.Int" qualified as @HoppyDI@. +hsImportForInt :: HsImportSet +hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI" + +-- | Imports "Data.Word" qualified as @HoppyDW@. +hsImportForWord :: HsImportSet +hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW" + +-- | Imports "Foreign" qualified as @HoppyF@. +hsImportForForeign :: HsImportSet +hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF" + +-- | Imports "Foreign.C" qualified as @HoppyFC@. +hsImportForForeignC :: HsImportSet +hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC" + +-- | Imports "Data.Map" qualified as @HoppyDM@. +hsImportForMap :: HsImportSet +hsImportForMap = hsQualifiedImport "Data.Map" "HoppyDM" + +-- | Imports "Prelude" qualified as @HoppyP@. +hsImportForPrelude :: HsImportSet +hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP" + +-- | Imports "Foreign.Hoppy.Runtime" qualified as @HoppyFHR@. +hsImportForRuntime :: HsImportSet +hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR" + +-- | Imports "System.Posix.Types" qualified as @HoppySPT@. +hsImportForSystemPosixTypes :: HsImportSet +hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT" -- | Imports "System.IO.Unsafe" qualified as @HoppySIU@. hsImportForUnsafeIO :: HsImportSet diff --git a/src/Foreign/Hoppy/Generator/Spec/Base.hs-boot b/src/Foreign/Hoppy/Generator/Spec/Base.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Base.hs-boot @@ -0,0 +1,41 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Spec.Base ( + ErrorMsg, + Reqs, + ExtName, + Identifier, + Constness, + HsImportSet, + ) where + +type ErrorMsg = String + +data Reqs + +newtype ExtName = ExtName { fromExtName :: String } + +newtype Identifier = Identifier + { identifierParts :: [IdPart] + } + +data IdPart + +data Constness + +data HsImportSet diff --git a/src/Foreign/Hoppy/Generator/Spec/Callback.hs b/src/Foreign/Hoppy/Generator/Spec/Callback.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Callback.hs @@ -0,0 +1,576 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Interface for defining foreign language callbacks. +module Foreign.Hoppy.Generator.Spec.Callback ( + -- * Data type + Callback, callbackT, + -- * Construction + makeCallback, + -- * Properties + callbackExtName, + callbackParams, + callbackReturn, + callbackReqs, + callbackAddendum, + -- ** Exceptions + callbackThrows, + callbackSetThrows, + -- * C++ generator + cppCallbackToTFn, + -- ** Names + callbackClassName, + callbackImplClassName, + callbackFnName, + -- * Haskell generator + hsCallbackToTFn, + -- ** Names + toHsCallbackCtorName, toHsCallbackCtorName', + toHsCallbackNewFunPtrFnName, toHsCallbackNewFunPtrFnName', + ) where + +import Control.Monad (forM_, when) +import Data.Function (on) +import Data.Maybe (fromMaybe, isJust) +import qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import Foreign.Hoppy.Generator.Spec.Base +import qualified Foreign.Hoppy.Generator.Spec.Function as Function +import Foreign.Hoppy.Generator.Types (boolT, constT, fnT, fnT', intT, manualT, ptrT, voidT) +import Language.Haskell.Syntax ( + HsName (HsIdent), + HsQName (Special, UnQual), + HsSpecialCon (HsUnitCon), + HsType (HsTyApp, HsTyCon, HsTyFun), + ) + +-- | A non-C++ function that can be invoked via a C++ functor or function +-- pointer. +-- +-- Use this data type's 'HasReqs' instance to add extra requirements, however +-- manually adding requirements for parameter and return types is not necessary. +data Callback = Callback + { callbackExtName :: ExtName + -- ^ The callback's external name. + , callbackParams :: [Parameter] + -- ^ The callback's parameters. + , callbackReturn :: Type + -- ^ The callback's return type. + , callbackThrows :: Maybe Bool + -- ^ Whether the callback supports throwing C++ exceptions from Haskell into + -- C++ during its execution. When absent, the value is inherited from + -- 'moduleCallbacksThrow' and 'interfaceCallbacksThrow'. + , callbackReqs :: Reqs + -- ^ Extra requirements for the callback. + , callbackAddendum :: Addendum + -- ^ The callback's addendum. + } + +instance Eq Callback where + (==) = (==) `on` callbackExtName + +instance Show Callback where + show cb = + concat [" ExtName + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> Callback +makeCallback extName paramTypes retType = + Callback extName (toParameters paramTypes) retType Nothing mempty mempty + +-- | Sets whether a callback supports handling thrown C++ exceptions and passing +-- them into C++. +callbackSetThrows :: Bool -> Callback -> Callback +callbackSetThrows value cb = cb { callbackThrows = Just value } + +makeConversion :: Callback -> ConversionSpec +makeConversion cb = + (makeConversionSpec (show cb) cpp) + { conversionSpecHaskell = hs } + where reqsGen = do + -- TODO Should this be includeStd? + cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$> + LC.findExportModule (callbackExtName cb) + -- TODO Is the right 'ReqsType' being used recursively here? + fnTypeReqs <- LC.typeReqs =<< cppCallbackToTFn cb + return $ cbClassReqs `mappend` fnTypeReqs + + cpp = + (makeConversionSpecCpp (callbackClassName cb) reqsGen) + { conversionSpecCppConversionType = return $ Just $ ptrT callbackImplClassType + , conversionSpecCppConversionToCppExpr = Just $ \fromVar maybeToVar -> case maybeToVar of + Just toVar -> + LC.says [callbackClassName cb, " "] >> toVar >> LC.say "(" >> + fromVar >> LC.say ");\n" + Nothing -> LC.says [callbackClassName cb, "("] >> fromVar >> LC.say ")" + -- No from-C++ conversion; we don't support passing callbacks back out again. + } + + hs = + Just $ makeConversionSpecHaskell + (LH.cppTypeToHsTypeAndUse LH.HsHsSide =<< hsCallbackToTFn LH.HsHsSide cb) + (Just $ do + LH.addImports hsImportForRuntime + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") <$> + (LH.cppTypeToHsTypeAndUse LH.HsCSide =<< hsCallbackToTFn LH.HsCSide cb)) + (CustomConversion $ LH.sayLn =<< toHsCallbackCtorName cb) + ConversionUnsupported -- Can't receive a callback from C++. + + callbackImplClassType = + manualT $ + makeConversionSpec implClass $ + makeConversionSpecCpp implClass reqsGen + + implClass = callbackImplClassName cb + +-- | Constructs a type value for a callback. +callbackT :: Callback -> Type +-- (Keep docs in sync with hs-boot.) +callbackT = manualT . makeConversion + +-- | Returns the name of the outer, copyable C++ class for a callback. +callbackClassName :: Callback -> String +callbackClassName = fromExtName . callbackExtName + +-- | Returns the name of the internal, non-copyable implementation C++ class for +-- a callback. +callbackImplClassName :: Callback -> String +callbackImplClassName = (++ "_impl") . fromExtName . callbackExtName + +-- | Returns the name of the C++ binding function that creates a C++ callback +-- wrapper object from a function pointer to foreign code. +callbackFnName :: Callback -> String +callbackFnName = LC.externalNameToCpp . callbackExtName + +sayCppExport :: LC.SayExportMode -> Callback -> LC.Generator () +sayCppExport mode cb = do + throws <- cppGetEffectiveCallbackThrows cb + + let className = callbackClassName cb + implClassName = callbackImplClassName cb + fnName = callbackFnName cb + params = callbackParams cb + paramTypes = map parameterType params + paramCount = length params + retType = callbackReturn cb + fnType = fnT' params retType + + -- The function pointer we receive from foreign code will work with C-types, + -- so determine what that function looks like. + paramCTypes <- zipWith fromMaybe paramTypes <$> mapM LC.typeToCType paramTypes + retCType <- fromMaybe retType <$> LC.typeToCType retType + + -- Add requirements specified manually by the callback, and for its parameter + -- and return types. + LC.addReqsM . mconcat . (callbackReqs cb:) =<< mapM LC.typeReqs (retType:paramTypes) + + let fnCType = fnT ((if throws then (++ [ptrT intT, ptrT $ ptrT voidT]) else id) + paramCTypes) + retCType + fnPtrCType = ptrT fnCType + + case mode of + LC.SayHeader -> do + -- Render the class declarations into the header file. + (sharedPtrReqs, sharedPtrStr) <- interfaceSharedPtr <$> LC.askInterface + LC.addReqsM sharedPtrReqs + + LC.says ["\nclass ", implClassName, " {\n"] + LC.say "public:\n" + LC.says [" explicit ", implClassName, "("] >> LC.sayType Nothing fnPtrCType >> + LC.say ", void(*)(void(*)()), bool);\n" + LC.says [" ~", implClassName, "();\n"] + LC.say " " >> LC.sayVar "operator()" Nothing fnType >> LC.say ";\n" + LC.say "private:\n" + LC.says [" ", implClassName, "(const ", implClassName, "&);\n"] + LC.says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"] + LC.say "\n" + LC.say " " >> LC.sayVar "f_" Nothing (constT fnPtrCType) >> LC.say ";\n" + LC.say " void (*const release_)(void(*)());\n" + LC.say " const bool releaseRelease_;\n" + LC.say "};\n" + + LC.says ["\nclass ", className, " {\n"] + LC.say "public:\n" + LC.says [" ", className, "() {}\n"] + LC.says [" explicit ", className, "(", implClassName, "* impl) : impl_(impl) {}\n"] + LC.say " " >> LC.sayVar "operator()" Nothing fnType >> LC.say ";\n" + LC.say " operator bool() const;\n" + LC.say "private:\n" + LC.says [" ", sharedPtrStr, "<", implClassName, "> impl_;\n"] + LC.say "};\n" + + LC.SaySource -> do + -- Render the classes' methods into the source file. First render the + -- impl class's constructor. + LC.says ["\n", implClassName, "::", implClassName, "("] >> LC.sayVar "f" Nothing fnPtrCType >> + LC.say ", void (*release)(void(*)()), bool releaseRelease) :\n" + LC.say " f_(f), release_(release), releaseRelease_(releaseRelease) {}\n" + + -- Then render the destructor. + LC.says ["\n", implClassName, "::~", implClassName, "() {\n"] + LC.say " if (release_) {\n" + LC.say " release_(reinterpret_cast(f_));\n" + LC.say " if (releaseRelease_) {\n" + LC.say " release_(reinterpret_cast(release_));\n" + LC.say " }\n" + LC.say " }\n" + LC.say "}\n" + + -- Render the impl operator() method, which does argument decoding and + -- return value encoding and passes C++ values to underlying function + -- poiner. + -- + -- TODO Abstract the duplicated code here and in sayExportFn. + paramCTypeMaybes <- mapM LC.typeToCType paramTypes + retCTypeMaybe <- LC.typeToCType retType + + LC.sayFunction (implClassName ++ "::operator()") + (zipWith3 (\pt ctm -> + -- TManual needs special handling to determine whether a + -- conversion is necessary. 'typeToCType' doesn't suffice + -- because for TManual this check relies on the direction of + -- the call. See the special case in 'sayCppArgRead' as + -- well. + let hasConversion = case pt of + Internal_TManual s -> + isJust $ conversionSpecCppConversionToCppExpr $ + conversionSpecCpp s + _ -> isJust ctm + in if hasConversion then LC.toArgNameAlt else LC.toArgName) + paramTypes + paramCTypeMaybes + [1..paramCount]) + fnType $ Just $ do + -- Convert arguments that aren't passed in directly. + mapM_ (Function.sayCppArgRead Function.FromCpp) $ + zip3 [1..] paramTypes paramCTypeMaybes + + when throws $ do + LC.says ["int ", LC.exceptionIdArgName, " = 0;\n"] + LC.says ["void *", LC.exceptionPtrArgName, " = 0;\n"] + + -- Add an include for the exception support module to be able to call the + -- C++ rethrow function. + iface <- LC.askInterface + currentModule <- LC.askModule + case interfaceExceptionSupportModule iface of + Just exceptionSupportModule -> + when (exceptionSupportModule /= currentModule) $ + -- TODO Should this be includeStd? + LC.addReqsM $ reqInclude $ includeLocal $ moduleHppPath exceptionSupportModule + Nothing -> LC.abort $ "sayExportCallback: " ++ show iface ++ + " uses exceptions, so it needs an exception support " ++ + "module. Please use interfaceSetExceptionSupportModule." + + -- Invoke the function pointer into foreign code. + let -- | Generates the call to the foreign language function pointer. + sayCall :: LC.Generator () + sayCall = do + LC.say "f_(" + Function.sayCppArgNames paramCount + when throws $ do + when (paramCount /= 0) $ LC.say ", " + LC.says ["&", LC.exceptionIdArgName, ", &", LC.exceptionPtrArgName] + LC.say ")" + + -- | Generates code to check whether an exception was thrown by the + -- callback, and rethrows it in C++ if so. + sayExceptionCheck :: LC.Generator () + sayExceptionCheck = when throws $ do + LC.says ["if (", LC.exceptionIdArgName, " != 0) { ", + LC.exceptionRethrowFnName, "(", LC.exceptionIdArgName, ", ", + LC.exceptionPtrArgName, "); }\n"] + + case (retType, retCTypeMaybe) of + (Internal_TVoid, Nothing) -> do + sayCall >> LC.say ";\n" + sayExceptionCheck + (_, Nothing) -> do + LC.sayVar "result" Nothing retType >> LC.say " = " >> sayCall >> LC.say ";\n" + sayExceptionCheck + LC.say "return result;\n" + (Internal_TObj cls1, + Just retCType'@(Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) + | cls1 == cls2 -> do + LC.sayVar "resultPtr" Nothing retCType' >> LC.say " = " >> sayCall >> LC.say ";\n" + sayExceptionCheck + LC.sayVar "result" Nothing retType >> LC.say " = *resultPtr;\n" + LC.say "delete resultPtr;\n" + LC.say "return result;\n" + (Internal_TRef (Internal_TConst (Internal_TObj cls1)), + Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do + LC.sayVar "resultPtr" Nothing retCType >> LC.say " = " >> sayCall >> LC.say ";\n" + sayExceptionCheck + LC.say "return *resultPtr;\n" + (Internal_TRef (Internal_TObj cls1), + Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do + LC.sayVar "resultPtr" Nothing retCType >> LC.say " = " >> sayCall >> LC.say ";\n" + sayExceptionCheck + LC.say "return *resultPtr;\n" + ts -> LC.abort $ concat + ["sayExportCallback: Unexpected return types ", show ts, "."] + + -- Render the non-impl operator() method, which simply passes C++ values + -- along to the impl object. + LC.sayFunction (className ++ "::operator()") + (map LC.toArgName [1..paramCount]) + fnType $ Just $ do + case retType of + Internal_TVoid -> LC.say "(*impl_)(" + _ -> LC.say "return (*impl_)(" + Function.sayCppArgNames paramCount + LC.say ");\n" + + -- Render "operator bool", which detects whether the callback was not + -- default-constructed with no actual impl object. + LC.says [className, "::operator bool() const {\n"] + LC.say "return static_cast(impl_);\n" + LC.say "}\n" + + -- Render the function that creates a new callback object. + let newCallbackFnType = fnT [ fnPtrCType + , ptrT (fnT [ptrT $ fnT [] voidT] voidT) + , boolT + ] $ + Internal_TManual $ + makeConversionSpec ("") $ + makeConversionSpecCpp (implClassName ++ "*") (return mempty) + LC.sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $ + LC.says ["return new ", implClassName, "(f, release, releaseRelease);\n"] + +-- | Prints \"foreign import\" statements and an internal callback construction +-- function for a given 'Callback' specification. For example, for a callback +-- of 'LH.HsHsSide' type @Int -> String -> IO Int@, we will generate the +-- following bindings: +-- +-- > foreign import ccall "wrapper" name'newFunPtr +-- > :: (CInt -> Ptr CChar -> IO CInt) +-- > -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt)) +-- > +-- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.) +-- > foreign import ccall "genpop__name_impl" name'newCallback +-- > :: FunPtr (CInt -> Ptr CChar -> IO CInt) +-- > -> FunPtr (FunPtr (IO ()) -> IO ()) +-- > -> Bool +-- > -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) +-- > +-- > name_newFunPtr :: (Int -> String -> IO Int) -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt)) +-- > name_newFunPtr f'hs = name'newFunPtr $ \excIdPtr excPtrPtr arg1 arg2 -> +-- > internalHandleCallbackExceptions excIdPtr excPtrPtr $ +-- > coerceIntegral arg1 >>= \arg1' -> +-- > (...decode the C string) >>= \arg2' -> +-- > fmap coerceIntegral +-- > (f'hs arg1' arg2') +-- > +-- > name_new :: (Int -> String -> IO Int) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) +-- > name_new f = do +-- > f'p <- name_newFunPtr f +-- > name'newCallback f'p freeHaskellFunPtrFunPtr False +sayHsExport :: LH.SayExportMode -> Callback -> LH.Generator () +sayHsExport mode cb = + LH.withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do + let name = callbackExtName cb + params = callbackParams cb + retType = callbackReturn cb + hsNewFunPtrFnName <- toHsCallbackNewFunPtrFnName cb + hsCtorName <- toHsCallbackCtorName cb + let hsCtorName'newCallback = hsCtorName ++ "'newCallback" + hsCtorName'newFunPtr = hsCtorName ++ "'newFunPtr" + + hsFnCType <- LH.cppTypeToHsTypeAndUse LH.HsCSide =<< hsCallbackToTFn LH.HsCSide cb + hsFnHsType <- LH.cppTypeToHsTypeAndUse LH.HsHsSide =<< hsCallbackToTFn LH.HsHsSide cb + + let getWholeNewFunPtrFnType = do + LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude] + return $ + HsTyFun hsFnHsType $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType + + getWholeCtorType = do + LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + return $ + HsTyFun hsFnHsType $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType + + case mode of + LH.SayExportForeignImports -> do + LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime] + let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType + hsFunPtrImportType = + HsTyFun hsFnCType $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType + hsCallbackCtorImportType = + HsTyFun hsFunPtrType $ + HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $ + HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ + HsTyCon $ Special HsUnitCon) $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ + HsTyCon $ Special HsUnitCon) $ + HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType + + LH.saysLn ["foreign import ccall \"wrapper\" ", hsCtorName'newFunPtr, " :: ", + LH.prettyPrint hsFunPtrImportType] + LH.saysLn ["foreign import ccall \"", LC.externalNameToCpp name, "\" ", + hsCtorName'newCallback, " :: ", LH.prettyPrint hsCallbackCtorImportType] + + LH.SayExportDecls -> do + LH.addExports [hsNewFunPtrFnName, hsCtorName] + + -- Generate the *_newFunPtr function. + wholeNewFunPtrFnType <- getWholeNewFunPtrFnType + let paramCount = length params + argNames = map LH.toArgName [1..paramCount] + argNames' = map (++ "'") argNames + throws <- hsGetEffectiveCallbackThrows cb + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForRuntime] + LH.ln + LH.saysLn [hsNewFunPtrFnName, " :: ", LH.prettyPrint wholeNewFunPtrFnType] + LH.saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" : + case (if throws then (++ ["excIdPtr", "excPtrPtr"]) else id) argNames of + [] -> [] + argNames'' -> [" \\", unwords argNames'', " ->"] + LH.indent $ do + when throws $ LH.sayLn "HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $" + forM_ (zip3 params argNames argNames') $ \(p, argName, argName') -> + Function.sayHsArgProcessing Function.FromCpp (parameterType p) argName argName' + Function.sayHsCallAndProcessReturn Function.FromCpp retType $ + "f'hs" : map (' ':) argNames' + + -- Generate the *_new function. + wholeCtorType <- getWholeCtorType + LH.ln + LH.saysLn [hsCtorName, " :: ", LH.prettyPrint wholeCtorType] + LH.saysLn [hsCtorName, " f'hs = do"] + LH.indent $ do + LH.saysLn ["f'p <- ", hsNewFunPtrFnName, " f'hs"] + LH.saysLn [hsCtorName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"] + + LH.SayExportBoot -> do + LH.addExports [hsNewFunPtrFnName, hsCtorName] + wholeNewFunPtrFnType <- getWholeNewFunPtrFnType + wholeCtorType <- getWholeCtorType + LH.ln + LH.saysLn [hsNewFunPtrFnName, " :: ", LH.prettyPrint wholeNewFunPtrFnType] + LH.ln + LH.saysLn [hsCtorName, " :: ", LH.prettyPrint wholeCtorType] + +-- | The name of the function that takes a Haskell function and wraps it in a +-- callback object. This is internal to the binding; normal users can pass +-- Haskell functions to be used as callbacks inplicitly. +toHsCallbackCtorName :: Callback -> LH.Generator String +toHsCallbackCtorName callback = + LH.inFunction "toHsCallbackCtorName" $ + LH.addExtNameModule (callbackExtName callback) $ toHsCallbackCtorName' callback + +-- | Pure version of 'toHsCallbackCtorName' that doesn't create a qualified +-- name. +toHsCallbackCtorName' :: Callback -> String +toHsCallbackCtorName' callback = + LH.toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_new" + +-- | The name of the function that takes a Haskell function with Haskell-side +-- types and wraps it in a 'Foreign.Ptr.FunPtr' that does appropriate +-- conversions to and from C-side types. +toHsCallbackNewFunPtrFnName :: Callback -> LH.Generator String +toHsCallbackNewFunPtrFnName callback = + LH.inFunction "toHsCallbackNewFunPtrFnName" $ + LH.addExtNameModule (callbackExtName callback) $ toHsCallbackNewFunPtrFnName' callback + +-- | Pure version of 'toHsCallbackNewFunPtrFnName' that doesn't create a qualified +-- name. +toHsCallbackNewFunPtrFnName' :: Callback -> String +toHsCallbackNewFunPtrFnName' callback = + LH.toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_newFunPtr" + +cppGetEffectiveCallbackThrows :: Callback -> LC.Generator Bool +cppGetEffectiveCallbackThrows cb = case callbackThrows cb of + Just b -> return b + Nothing -> moduleCallbacksThrow <$> LC.askModule >>= \case + Just b -> return b + Nothing -> interfaceCallbacksThrow <$> LC.askInterface + +hsGetEffectiveCallbackThrows :: Callback -> LH.Generator Bool +hsGetEffectiveCallbackThrows cb = case callbackThrows cb of + Just b -> return b + Nothing -> moduleCallbacksThrow <$> LH.askModule >>= \case + Just b -> return b + Nothing -> interfaceCallbacksThrow <$> LH.askInterface + +-- | Constructs the function type for a callback. A callback that throws has +-- additional parameters. +-- +-- Keep this in sync with 'hsCallbackToTFn'. +cppCallbackToTFn :: Callback -> LC.Generator Type +cppCallbackToTFn cb = do + throws <- mayThrow + return $ Internal_TFn ((if throws then addExcParams else id) $ callbackParams cb) + (callbackReturn cb) + + where mayThrow = case callbackThrows cb of + Just t -> return t + Nothing -> moduleCallbacksThrow <$> LC.askModule >>= \mt -> case mt of + Just t -> return t + Nothing -> interfaceCallbacksThrow <$> LC.askInterface + + addExcParams = (++ [toParameter $ ptrT intT, toParameter $ ptrT $ ptrT voidT]) + +-- | Constructs the function type for a callback. For Haskell, the type depends +-- on the side; the C++ side has additional parameters. +-- +-- Keep this in sync with 'cppCallbackToTFn'. +hsCallbackToTFn :: LH.HsTypeSide -> Callback -> LH.Generator Type +hsCallbackToTFn side cb = do + needsExcParams <- case side of + LH.HsCSide -> mayThrow + LH.HsHsSide -> return False + return $ Internal_TFn ((if needsExcParams then addExcParams else id) $ callbackParams cb) + (callbackReturn cb) + + where mayThrow = case callbackThrows cb of + Just t -> return t + Nothing -> moduleCallbacksThrow <$> LH.askModule >>= \mt -> case mt of + Just t -> return t + Nothing -> interfaceCallbacksThrow <$> LH.askInterface + + addExcParams = (++ [toParameter $ ptrT intT, toParameter $ ptrT $ ptrT voidT]) diff --git a/src/Foreign/Hoppy/Generator/Spec/Callback.hs-boot b/src/Foreign/Hoppy/Generator/Spec/Callback.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Callback.hs-boot @@ -0,0 +1,27 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Spec.Callback ( + callbackT, + ) where + +import Foreign.Hoppy.Generator.Spec.Base (Type) + +data Callback + +-- | Constructs a type value for a callback. +callbackT :: Callback -> Type diff --git a/src/Foreign/Hoppy/Generator/Spec/Class.hs b/src/Foreign/Hoppy/Generator/Spec/Class.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Class.hs @@ -0,0 +1,2116 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Interface for defining bindings to C++ classes. +module Foreign.Hoppy.Generator.Spec.Class ( + -- * Data type + Class, + -- * Construction + makeClass, + -- * Properties + -- ** Common + classExtName, + classIdentifier, + classReqs, + classAddendum, + -- ** Class hierarchy + classSuperclasses, + classIsMonomorphicSuperclass, classSetMonomorphicSuperclass, + classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic, + -- ** Entities + classEntities, classAddEntities, classVariables, classCtors, classMethods, + classEntityPrefix, classSetEntityPrefix, + classDtorIsPublic, classSetDtorPrivate, + classConversion, + classIsException, classMakeException, + -- * Entity types + ClassEntity (..), IsClassEntity (..), + classEntityExtName, classEntityExtNames, + classEntityForeignName, classEntityForeignName', + -- ** Class variables + ClassVariable, + -- *** Construction + makeClassVariable, makeClassVariable_, + mkClassVariable, mkClassVariable_, + mkStaticClassVariable, + mkStaticClassVariable_, + -- ** Constructors + Ctor, + -- *** Construction + makeCtor, makeCtor_, + mkCtor, mkCtor_, + -- *** Properties + ctorExtName, + ctorParams, + ctorExceptionHandlers, + -- ** Methods (member functions) + Method, MethodApplicability (..), Staticness (..), MethodImpl (..), + -- *** Construction + makeMethod, makeMethod_, + makeFnMethod, makeFnMethod_, + mkMethod, mkMethod_, mkMethod', mkMethod'_, + mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_, + mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_, + -- *** Properties + methodExtName, methodImpl, methodApplicability, methodConst, methodStatic, methodPurity, + methodParams, methodReturn, methodExceptionHandlers, + -- ** Class properties (getter/setter pairs) + Prop, + -- ** Construction + mkProp, mkProp_, + mkStaticProp, mkStaticProp_, + mkBoolIsProp, mkBoolIsProp_, + mkBoolHasProp, mkBoolHasProp_, + -- * Conversions + ClassConversion (..), classConversionNone, classModifyConversion, classSetConversion, + ClassHaskellConversion (..), classSetHaskellConversion, + -- * Haskell generator + -- ** Names + toHsValueClassName, toHsValueClassName', + toHsWithValuePtrName, toHsWithValuePtrName', + toHsPtrClassName, toHsPtrClassName', + toHsCastMethodName, toHsCastMethodName', + toHsDownCastClassName, toHsDownCastClassName', + toHsDownCastMethodName, toHsDownCastMethodName', + toHsCastPrimitiveName, toHsCastPrimitiveName', + toHsConstCastFnName, toHsConstCastFnName', + toHsDataTypeName, toHsDataTypeName', + toHsDataCtorName, toHsDataCtorName', + toHsClassDeleteFnName', + toHsClassDeleteFnPtrName', + toHsCtorName, toHsCtorName', + toHsMethodName, toHsMethodName', + toHsClassEntityName, toHsClassEntityName', + -- * Internal + classFindCopyCtor, + sayCppExportVar, + sayHsExportVar, + ) where + +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.Except (throwError) +import Data.Char (toUpper) +import Data.Function (on) +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.List (intersperse) +import Foreign.Hoppy.Generator.Common (fromMaybeM, lowerFirst) +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import Foreign.Hoppy.Generator.Spec.Base +import qualified Foreign.Hoppy.Generator.Spec.Function as Function +import Foreign.Hoppy.Generator.Types (boolT, constT, fnT, objT, ptrT, refT, voidT) +import GHC.Stack (HasCallStack) +import Language.Haskell.Syntax ( + HsName (HsIdent), + HsQName (UnQual), + HsType (HsTyCon, HsTyFun, HsTyVar), + ) + +-- | A C++ class declaration. See 'IsClassEntity' for more information about the +-- interaction between a class's names and the names of entities within the +-- class. +-- +-- Use this data type's 'HasReqs' instance to make the class accessible. You do +-- not need to add requirements for methods' parameter or return types. +data Class = Class + { classExtName :: ExtName + -- ^ The class's external name. + , classIdentifier :: Identifier + -- ^ The identifier used to refer to the class. + , classSuperclasses :: [Class] + -- ^ The class's public superclasses. + , classEntities :: [ClassEntity] + -- ^ The class's entities. + , classDtorIsPublic :: Bool + -- ^ The class's methods. + , classConversion :: ClassConversion + -- ^ Behaviour for converting objects to and from foriegn values. + , classReqs :: Reqs + -- ^ Requirements for bindings to access this class. + , classAddendum :: Addendum + -- ^ The class's addendum. + , classIsMonomorphicSuperclass :: Bool + -- ^ This is true for classes passed through + -- 'classSetMonomorphicSuperclass'. + , classIsSubclassOfMonomorphic :: Bool + -- ^ This is true for classes passed through + -- 'classSetSubclassOfMonomorphic'. + , classIsException :: Bool + -- ^ Whether to support using the class as a C++ exception. + , classEntityPrefix :: String + -- ^ The prefix applied to the external names of entities (methods, etc.) + -- within this class when determining the names of foreign languages' + -- corresponding bindings. This defaults to the external name of the class, + -- plus an underscore. Changing this allows you to potentially have + -- entities with the same foreign name in separate modules. This may be the + -- empty string, in which case the foreign name will simply be the external + -- name of the entity. + -- + -- This does __not__ affect the things' external names themselves; external + -- names must still be unique in an interface. For instance, a method with + -- external name @bar@ in a class with external name @Flab@ and prefix + -- @Flob_@ will use the effective external name @Flab_bar@, but the + -- generated name in say Haskell would be @Flob_bar@. + -- + -- See 'IsClassEntity' and 'classSetEntityPrefix'. + } + +instance Eq Class where + (==) = (==) `on` classExtName + +instance Ord Class where + compare = compare `on` classExtName + +instance Show Class where + show cls = + concat [""] + +instance Exportable Class where + sayExportCpp = sayCppExport + + sayExportHaskell = sayHsExport + + getExportExceptionClass cls = + if classIsException cls + then Just cls + else Nothing + +instance HasExtNames Class where + getPrimaryExtName = classExtName + getNestedExtNames cls = concatMap (classEntityExtNames cls) $ classEntities cls + +instance HasReqs Class where + getReqs = classReqs + setReqs reqs cls = cls { classReqs = reqs } + +instance HasAddendum Class where + getAddendum = classAddendum + setAddendum addendum cls = cls { classAddendum = addendum } + +-- | Creates a binding for a C++ class and its contents. +makeClass :: Identifier + -> Maybe ExtName + -- ^ An optional external name; will be automatically derived from the + -- identifier if absent by dropping leading namespaces, and taking the + -- last component (sans template arguments). + -> [Class] -- ^ Superclasses. + -> [ClassEntity] + -> Class +makeClass identifier maybeExtName supers entities = + let extName = extNameOrIdentifier identifier maybeExtName + in Class + { classIdentifier = identifier + , classExtName = extName + , classSuperclasses = supers + , classEntities = entities + , classDtorIsPublic = True + , classConversion = classConversionNone + , classReqs = mempty + , classAddendum = mempty + , classIsMonomorphicSuperclass = False + , classIsSubclassOfMonomorphic = False + , classIsException = False + , classEntityPrefix = fromExtName extName ++ "_" + } + +-- | Sets the prefix applied to foreign languages' entities generated from +-- methods, etc. within the class. +-- +-- See 'IsClassEntity' and 'classEntityPrefix'. +classSetEntityPrefix :: String -> Class -> Class +classSetEntityPrefix prefix cls = cls { classEntityPrefix = prefix } + +-- | Adds constructors to a class. +classAddEntities :: [ClassEntity] -> Class -> Class +classAddEntities ents cls = + if null ents then cls else cls { classEntities = classEntities cls ++ ents } + +-- | Returns all of the class's variables. +classVariables :: Class -> [ClassVariable] +classVariables = mapMaybe pickVar . classEntities + where pickVar ent = case ent of + CEVar v -> Just v + CECtor _ -> Nothing + CEMethod _ -> Nothing + CEProp _ -> Nothing + +-- | Returns all of the class's constructors. +classCtors :: Class -> [Ctor] +classCtors = mapMaybe pickCtor . classEntities + where pickCtor ent = case ent of + CEVar _ -> Nothing + CECtor ctor -> Just ctor + CEMethod _ -> Nothing + CEProp _ -> Nothing + +-- | Returns all of the class's methods, including methods generated from +-- 'Prop's. +classMethods :: Class -> [Method] +classMethods = concatMap pickMethods . classEntities + where pickMethods ent = case ent of + CEVar _ -> [] + CECtor _ -> [] + CEMethod m -> [m] + CEProp (Prop ms) -> ms + +-- | Marks a class's destructor as private, so that a binding for it won't be +-- generated. +classSetDtorPrivate :: Class -> Class +classSetDtorPrivate cls = cls { classDtorIsPublic = False } + +-- | Explicitly marks a class as being monomorphic (i.e. not having any +-- virtual methods or destructors). By default, Hoppy assumes that a class that +-- is derived is also polymorphic, but it can happen that this is not the case. +-- Downcasting with @dynamic_cast@ from such classes is not available. See also +-- 'classSetSubclassOfMonomorphic'. +classSetMonomorphicSuperclass :: Class -> Class +classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True } + +-- | Marks a class as being derived from some monomorphic superclass. This +-- prevents any downcasting to this class. Generally it is better to use +-- 'classSetMonomorphicSuperclass' on the specific superclasses that are +-- monomorphic, but in cases where this is not possible, this function can be +-- applied to the subclass instead. +classSetSubclassOfMonomorphic :: Class -> Class +classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True } + +-- | Marks a class as being used as an exception. This makes the class +-- throwable and catchable. +classMakeException :: Class -> Class +classMakeException cls = case classIsException cls of + False -> cls { classIsException = True } + True -> cls + +-- | Separately from passing object handles between C++ and foreign languages, +-- objects can also be made to implicitly convert to native values in foreign +-- languages. A single such type may be associated with any C++ class for each +-- foreign language. The foreign type and the conversion process in each +-- direction are specified using this object. Converting a C++ object to a +-- foreign value is also called decoding, and vice versa is called encoding. A +-- class may be convertible in one direction and not the other. +-- +-- To use these implicit conversions, instead of specifying an object handle +-- type such as +-- @'Foreign.Hoppy.Generator.Types.ptrT' . 'Foreign.Hoppy.Generator.Types.objT'@ +-- or +-- @'Foreign.Hoppy.Generator.Types.refT' . 'Foreign.Hoppy.Generator.Types.objT'@, +-- use 'Foreign.Hoppy.Generator.Types.objT' directly. +-- +-- The subfields in this object specify how to do conversions between C++ and +-- foreign languages. +data ClassConversion = ClassConversion + { classHaskellConversion :: ClassHaskellConversion + -- ^ Conversions to and from Haskell. + + -- NOTE! When adding new languages here, add the language to + -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the + -- language supports garbage collection. + } + +-- | Conversion behaviour for a class that is not convertible. +classConversionNone :: ClassConversion +classConversionNone = ClassConversion classHaskellConversionNone + +-- | Modifies a class's 'ClassConversion' structure with a given function. +classModifyConversion :: HasCallStack => (ClassConversion -> ClassConversion) -> Class -> Class +classModifyConversion f cls = + let cls' = cls { classConversion = f $ classConversion cls } + conv = classConversion cls' + haskellConv = classHaskellConversion conv + in case undefined of + _ | (isJust (classHaskellConversionToCppFn haskellConv) || + isJust (classHaskellConversionFromCppFn haskellConv)) && + isNothing (classHaskellConversionType haskellConv) -> + error $ "classModifyConversion: " ++ show cls' ++ + " was given a Haskell-to-C++ or C++-to-Haskell conversion function" ++ + " but no Haskell type. Please provide a classHaskellConversionType." + _ -> cls' + +-- | Replaces a class's 'ClassConversion' structure. +classSetConversion :: ClassConversion -> Class -> Class +classSetConversion c = classModifyConversion $ const c + +-- | Controls how conversions between C++ objects and Haskell values happen in +-- Haskell bindings. +data ClassHaskellConversion = ClassHaskellConversion + { classHaskellConversionType :: Maybe (LH.Generator HsType) + -- ^ Produces the Haskell type that represents a value of the corresponding + -- C++ class. This generator may add imports, but must not output code or + -- add exports. + , classHaskellConversionToCppFn :: Maybe (LH.Generator ()) + -- ^ Produces a Haskell expression that evaluates to a function that takes + -- an value of the type that 'classHaskellConversionType' generates, and + -- returns a non-const handle for a new C++ object in IO. The generator + -- must output code and may add imports, but must not add exports. + -- + -- If this field is present, then 'classHaskellConversionType' must also be + -- present. + , classHaskellConversionFromCppFn :: Maybe (LH.Generator ()) + -- ^ Produces a Haskell expression that evaluates to a function that takes a + -- const handle for a C++ object, and returns a value of the type that + -- 'classHaskellConversionType' generates, in IO. It should not delete the + -- handle. The generator must output code and may add imports, but must not + -- add exports. + -- + -- If this field is present, then 'classHaskellConversionType' must also be + -- present. + } + +-- | Conversion behaviour for a class that is not convertible to or from +-- Haskell. +classHaskellConversionNone :: ClassHaskellConversion +classHaskellConversionNone = + ClassHaskellConversion + { classHaskellConversionType = Nothing + , classHaskellConversionToCppFn = Nothing + , classHaskellConversionFromCppFn = Nothing + } + +-- | Replaces a class's 'classHaskellConversion' with a given value. +classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class +classSetHaskellConversion conv = classModifyConversion $ \c -> + c { classHaskellConversion = conv } + +-- | Things that live inside of a class, and have the class's external name +-- prepended to their own in generated code. With an external name of @\"bar\"@ +-- and a class with external name @\"foo\"@, the resulting name will be +-- @\"foo_bar\"@. +-- +-- See 'classEntityPrefix' and 'classSetEntityPrefix'. +class IsClassEntity a where + -- | Extracts the external name of the object, without the class name added. + classEntityExtNameSuffix :: a -> ExtName + +-- | Computes the external name to use in generated code, containing both the +-- class's and object's external names. This is the concatenation of the +-- class's and entity's external names, separated by an underscore. +classEntityExtName :: IsClassEntity a => Class -> a -> ExtName +classEntityExtName cls x = + toExtName $ fromExtName (classExtName cls) ++ "_" ++ fromExtName (classEntityExtNameSuffix x) + +-- | Computes the name under which a class entity is to be exposed in foreign +-- languages. This is the concatenation of a class's entity prefix, and the +-- external name of the entity. +classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName +classEntityForeignName cls x = + classEntityForeignName' cls $ classEntityExtNameSuffix x + +-- | Computes the name under which a class entity is to be exposed in foreign +-- languages, given a class and an entity's external name. The result is the +-- concatenation of a class's entity prefix, and the external name of the +-- entity. +classEntityForeignName' :: Class -> ExtName -> ExtName +classEntityForeignName' cls extName = + toExtName $ classEntityPrefix cls ++ fromExtName extName + +-- | A C++ entity that belongs to a class. +data ClassEntity = + CEVar ClassVariable + | CECtor Ctor + | CEMethod Method + | CEProp Prop + +-- | Returns all of the names in a 'ClassEntity' within the corresponding +-- 'Class'. +classEntityExtNames :: Class -> ClassEntity -> [ExtName] +classEntityExtNames cls ent = case ent of + CEVar v -> [classEntityExtName cls v] + CECtor ctor -> [classEntityExtName cls ctor] + CEMethod m -> [classEntityExtName cls m] + CEProp (Prop methods) -> map (classEntityExtName cls) methods + +-- | A C++ member variable. +data ClassVariable = ClassVariable + { classVarExtName :: ExtName + -- ^ The variable's external name. + , classVarCName :: String + -- ^ The variable's C++ name. + , classVarType :: Type + -- ^ The variable's type. This may be + -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is + -- read-only. + , classVarStatic :: Staticness + -- ^ Whether the variable is static (i.e. whether it exists once in the + -- class itself and not in each instance). + , classVarGettable :: Bool + -- ^ Whether the variable should have an accompanying getter. Note this + -- exists only for disabling getters on callback variables - as there is + -- currently no functionality to pass callbacks out of c++ + } + +instance Show ClassVariable where + show v = + concat [""] + +instance IsClassEntity ClassVariable where + classEntityExtNameSuffix = classVarExtName + +-- | Creates a 'ClassVariable' with full generality and manual name specification. +-- +-- The result is wrapped in a 'CEVar'. For an unwrapped value, use +-- 'makeClassVariable_'. +makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity +makeClassVariable cName maybeExtName tp static gettable = + CEVar $ makeClassVariable_ cName maybeExtName tp static gettable + +-- | The unwrapped version of 'makeClassVariable'. +makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable +makeClassVariable_ cName maybeExtName = + ClassVariable (extNameOrString cName maybeExtName) cName + +-- | Creates a 'ClassVariable' for a nonstatic class variable for +-- @class::varName@ whose external name is @class_varName@. +-- +-- The result is wrapped in a 'CEVar'. For an unwrapped value, use +-- 'mkClassVariable_'. +mkClassVariable :: String -> Type -> ClassEntity +mkClassVariable = (CEVar .) . mkClassVariable_ + +-- | The unwrapped version of 'mkClassVariable'. +mkClassVariable_ :: String -> Type -> ClassVariable +mkClassVariable_ cName t = makeClassVariable_ cName Nothing t Nonstatic True + +-- | Same as 'mkClassVariable', but returns a static variable instead. +-- +-- The result is wrapped in a 'CEVar'. For an unwrapped value, use +-- 'mkStaticClassVariable_'. +mkStaticClassVariable :: String -> Type -> ClassEntity +mkStaticClassVariable = (CEVar .) . mkStaticClassVariable_ + +-- | The unwrapped version of 'mkStaticClassVariable'. +mkStaticClassVariable_ :: String -> Type -> ClassVariable +mkStaticClassVariable_ cName t = makeClassVariable_ cName Nothing t Static True + +-- | Returns the external name of the getter function for the class variable. +classVarGetterExtName :: Class -> ClassVariable -> ExtName +classVarGetterExtName cls v = + toExtName $ fromExtName (classEntityExtName cls v) ++ "_get" + +-- | Returns the foreign name of the getter function for the class variable. +classVarGetterForeignName :: Class -> ClassVariable -> ExtName +classVarGetterForeignName cls v = + toExtName $ fromExtName (classEntityForeignName cls v) ++ "_get" + +-- | Returns the external name of the setter function for the class variable. +classVarSetterExtName :: Class -> ClassVariable -> ExtName +classVarSetterExtName cls v = + toExtName $ fromExtName (classEntityExtName cls v) ++ "_set" + +-- | Returns the foreign name of the setter function for the class variable. +classVarSetterForeignName :: Class -> ClassVariable -> ExtName +classVarSetterForeignName cls v = + toExtName $ fromExtName (classEntityForeignName cls v) ++ "_set" + +-- | A C++ class constructor declaration. +data Ctor = Ctor + { ctorExtName :: ExtName + -- ^ The constructor's external name. + , ctorParams :: [Parameter] + -- ^ The constructor's parameters. + , ctorExceptionHandlers :: ExceptionHandlers + -- ^ Exceptions that the constructor may throw. + } + +instance Show Ctor where + show ctor = concat [""] + +instance HandlesExceptions Ctor where + getExceptionHandlers = ctorExceptionHandlers + modifyExceptionHandlers f ctor = ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor } + +instance IsClassEntity Ctor where + classEntityExtNameSuffix = ctorExtName + +-- | Creates a 'Ctor' with full generality. +-- +-- The result is wrapped in a 'CECtor'. For an unwrapped value, use +-- 'makeCtor_'. +makeCtor :: IsParameter p => ExtName -> [p] -> ClassEntity +makeCtor = (CECtor .) . makeCtor_ + +-- | The unwrapped version of 'makeCtor'. +makeCtor_ :: IsParameter p => ExtName -> [p] -> Ctor +makeCtor_ extName params = Ctor extName (map toParameter params) mempty + +-- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@. +-- +-- The result is wrapped in a 'CECtor'. For an unwrapped value, use +-- 'makeCtor_'. +mkCtor :: IsParameter p => String -> [p] -> ClassEntity +mkCtor = (CECtor .) . mkCtor_ + +-- | The unwrapped version of 'mkCtor'. +mkCtor_ :: IsParameter p => String -> [p] -> Ctor +mkCtor_ extName params = makeCtor_ (toExtName extName) (map toParameter params) + +-- | Searches a class for a copy constructor, returning it if found. +classFindCopyCtor :: Class -> Maybe Ctor +classFindCopyCtor cls = case mapMaybe check $ classCtors cls of + [ctor] -> Just ctor + _ -> Nothing + where check ctor = + let paramTypes = map (stripConst . normalizeType . parameterType) $ ctorParams ctor + in if paramTypes == [Internal_TObj cls] || + paramTypes == [Internal_TRef $ Internal_TConst $ Internal_TObj cls] + then Just ctor + else Nothing + +-- | A C++ class method declaration. +-- +-- Any operator function that can be written as a method may have its binding be +-- written either as part of the associated class or as a separate entity, +-- independently of how the function is declared in C++. +data Method = Method + { methodImpl :: MethodImpl + -- ^ The underlying code that the binding calls. + , methodExtName :: ExtName + -- ^ The method's external name. + , methodApplicability :: MethodApplicability + -- ^ How the method is associated to its class. + , methodPurity :: Purity + -- ^ Whether the method is pure. + , methodParams :: [Parameter] + -- ^ The method's parameters. + , methodReturn :: Type + -- ^ The method's return type. + , methodExceptionHandlers :: ExceptionHandlers + -- ^ Exceptions that the method might throw. + } + +instance Show Method where + show method = + concat [" show name + FnMethod name -> show name, " ", + show (methodApplicability method), " ", + show (methodPurity method), " ", + show (methodParams method), " ", + show (methodReturn method), ">"] + +instance HandlesExceptions Method where + getExceptionHandlers = methodExceptionHandlers + + modifyExceptionHandlers f method = + method { methodExceptionHandlers = f $ methodExceptionHandlers method } + +instance IsClassEntity Method where + classEntityExtNameSuffix = methodExtName + +-- | The C++ code to which a 'Method' is bound. +data MethodImpl = + RealMethod (FnName String) + -- ^ The 'Method' is bound to an actual class method. + | FnMethod (FnName Identifier) + -- ^ The 'Method' is bound to a wrapper function. When wrapping a method + -- with another function, this is preferrable to just using a + -- 'Foreign.Hoppy.Generator.Spec.Function.Function' binding because a method + -- will still appear to be part of the class in foreign bindings. + deriving (Eq, Show) + +-- | How a method is associated to its class. A method may be static, const, or +-- neither (a regular method). +data MethodApplicability = MNormal | MStatic | MConst + deriving (Bounded, Enum, Eq, Show) + +-- | Whether or not a method is static. +data Staticness = Nonstatic | Static + deriving (Bounded, Enum, Eq, Show) + +-- | Returns the constness of a method, based on its 'methodApplicability'. +methodConst :: Method -> Constness +methodConst method = case methodApplicability method of + MConst -> Const + _ -> Nonconst + +-- | Returns the staticness of a method, based on its 'methodApplicability'. +methodStatic :: Method -> Staticness +methodStatic method = case methodApplicability method of + MStatic -> Static + _ -> Nonstatic + +-- | Creates a 'Method' with full generality and manual name specification. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'makeMethod_'. +makeMethod :: (IsFnName String name, IsParameter p) + => name -- ^ The C++ name of the method. + -> ExtName -- ^ The external name of the method. + -> MethodApplicability + -> Purity + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> ClassEntity +makeMethod = (((((CEMethod .) .) .) .) .) . makeMethod_ + +-- | The unwrapped version of 'makeMethod'. +makeMethod_ :: (IsFnName String name, IsParameter p) + => name + -> ExtName + -> MethodApplicability + -> Purity + -> [p] + -> Type + -> Method +makeMethod_ cName extName appl purity paramTypes retType = + Method (RealMethod $ toFnName cName) extName appl purity + (toParameters paramTypes) retType mempty + +-- | Creates a 'Method' that is in fact backed by a C++ non-member function (a +-- la 'Foreign.Hoppy.Generator.Spec.Function.makeFn'), but appears to be a +-- regular method. This is useful for wrapping a method on the C++ side when +-- its arguments aren't right for binding directly. +-- +-- A @this@ pointer parameter is __not__ automatically added to the parameter +-- list for non-static methods created with @makeFnMethod@. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'makeFnMethod_'. +makeFnMethod :: (IsFnName Identifier name, IsParameter p) + => name + -> String + -> MethodApplicability + -> Purity + -> [p] + -> Type + -> ClassEntity +makeFnMethod = (((((CEMethod .) .) .) .) .) . makeFnMethod_ + +-- | The unwrapped version of 'makeFnMethod'. +makeFnMethod_ :: (IsFnName Identifier name, IsParameter p) + => name + -> String + -> MethodApplicability + -> Purity + -> [p] + -> Type + -> Method +makeFnMethod_ cName foreignName appl purity paramTypes retType = + Method (FnMethod $ toFnName cName) (toExtName foreignName) + appl purity (toParameters paramTypes) retType mempty + +-- | This function is internal. +-- +-- Creates a method similar to 'makeMethod', but with automatic naming. The +-- method's external name will be @className ++ \"_\" ++ cppMethodName@. If the +-- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded +-- to the class name. +-- +-- For creating multiple bindings to a method, see @makeMethod''@. +makeMethod' :: (IsFnName String name, IsParameter p) + => name -- ^ The C++ name of the method. + -> MethodApplicability + -> Purity + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> Method +makeMethod' name = makeMethod''' (toFnName name) Nothing + +-- | This function is internal. +-- +-- Creates a method similar to @makeMethod'@, but with an custom string that +-- will be appended to the class name to form the method's external name. This +-- is useful for making multiple bindings to a method, e.g. for overloading and +-- optional arguments. +makeMethod'' :: (IsFnName String name, IsParameter p) + => name -- ^ The C++ name of the method. + -> String -- ^ A foreign name for the method. + -> MethodApplicability + -> Purity + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> Method +makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName + +-- | The implementation of @makeMethod'@ and @makeMethod''@. +makeMethod''' :: (HasCallStack, IsParameter p) + => FnName String -- ^ The C++ name of the method. + -> Maybe String -- ^ A foreign name for the method. + -> MethodApplicability + -> Purity + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> Method +makeMethod''' (FnName "") maybeForeignName _ _ paramTypes retType = + error $ concat ["makeMethod''': Given an empty method name with foreign name ", + show maybeForeignName, ", parameter types ", show paramTypes, + ", and return type ", show retType, "."] +makeMethod''' name (Just "") _ _ paramTypes retType = + error $ concat ["makeMethod''': Given an empty foreign name with method ", + show name, ", parameter types ", show paramTypes, ", and return type ", + show retType, "."] +makeMethod''' name maybeForeignName appl purity paramTypes retType = + let extName = flip fromMaybe (toExtName <$> maybeForeignName) $ case name of + FnName s -> toExtName s + FnOp op -> operatorPreferredExtName op + in makeMethod_ name extName appl purity (toParameters paramTypes) retType + +-- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose +-- external name is @class_methodName@. If the name is an operator, then the +-- 'operatorPreferredExtName' will be used in the external name. +-- +-- For creating multiple bindings to a method, see 'mkMethod''. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkMethod_'. +mkMethod :: (IsFnName String name, IsParameter p) + => name -- ^ The C++ name of the method. + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> ClassEntity +mkMethod = ((CEMethod .) .) . mkMethod_ + +-- | The unwrapped version of 'mkMethod'. +mkMethod_ :: (IsFnName String name, IsParameter p) + => name + -> [p] + -> Type + -> Method +mkMethod_ name = makeMethod' name MNormal Nonpure + +-- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and +-- whose external name is @class_methodName@. This enables multiple 'Method's +-- with different foreign names (and hence different external names) to bind to +-- the same method, e.g. to make use of optional arguments or overloading. See +-- 'mkMethod' for a simpler form. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkMethod'_'. +mkMethod' :: (IsFnName String name, IsParameter p) + => name -- ^ The C++ name of the method. + -> String -- ^ A foreign name for the method. + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> ClassEntity +mkMethod' = (((CEMethod .) .) .) . mkMethod'_ + +-- | The unwrapped version of 'mkMethod''. +mkMethod'_ :: (IsFnName String name, IsParameter p) + => name + -> String + -> [p] + -> Type + -> Method +mkMethod'_ cName foreignName = makeMethod'' cName foreignName MNormal Nonpure + +-- | Same as 'mkMethod', but returns an 'MConst' method. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkConstMethod_'. +mkConstMethod :: (IsFnName String name, IsParameter p) + => name + -> [p] + -> Type + -> ClassEntity +mkConstMethod = ((CEMethod .) .) . mkConstMethod_ + +-- | The unwrapped version of 'mkConstMethod'. +mkConstMethod_ :: (IsFnName String name, IsParameter p) + => name + -> [p] + -> Type + -> Method +mkConstMethod_ name = makeMethod' name MConst Nonpure + +-- | Same as 'mkMethod'', but returns an 'MConst' method. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkConstMethod'_'. +mkConstMethod' :: (IsFnName String name, IsParameter p) + => name + -> String + -> [p] + -> Type + -> ClassEntity +mkConstMethod' = (((CEMethod .) .) .) . mkConstMethod'_ + +-- | The unwrapped version of 'mkConstMethod''. +mkConstMethod'_ :: (IsFnName String name, IsParameter p) + => name + -> String + -> [p] + -> Type + -> Method +mkConstMethod'_ cName foreignName = makeMethod'' cName foreignName MConst Nonpure + +-- | Same as 'mkMethod', but returns an 'MStatic' method. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkStaticMethod_'. +mkStaticMethod :: (IsFnName String name, IsParameter p) + => name + -> [p] + -> Type + -> ClassEntity +mkStaticMethod = ((CEMethod .) .) . mkStaticMethod_ + +-- | The unwrapped version of 'mkStaticMethod'. +mkStaticMethod_ :: (IsFnName String name, IsParameter p) + => name + -> [p] + -> Type + -> Method +mkStaticMethod_ name = makeMethod' name MStatic Nonpure + +-- | Same as 'mkMethod'', but returns an 'MStatic' method. +-- +-- The result is wrapped in a 'CEMethod'. For an unwrapped value, use +-- 'mkStaticMethod'_'. +mkStaticMethod' :: (IsFnName String name, IsParameter p) + => name + -> String + -> [p] + -> Type + -> ClassEntity +mkStaticMethod' = (((CEMethod .) .) .) . mkStaticMethod'_ + +-- | The unwrapped version of 'mkStaticMethod''. +mkStaticMethod'_ :: (IsFnName String name, IsParameter p) + => name + -> String + -> [p] + -> Type + -> Method +mkStaticMethod'_ cName foreignName = makeMethod'' cName foreignName MStatic Nonpure + +-- | A \"property\" getter/setter pair. +newtype Prop = Prop [Method] + +-- | Creates a getter/setter binding pair for methods: +-- +-- > T foo() const +-- > void setFoo(T) +-- +-- The result is wrapped in a 'CEProp'. For an unwrapped value, use +-- 'mkProp_'. +mkProp :: String -> Type -> ClassEntity +mkProp = (CEProp .) . mkProp_ + +-- | The unwrapped version of 'mkProp'. +mkProp_ :: String -> Type -> Prop +mkProp_ name t = + let c:cs = name + setName = 's' : 'e' : 't' : toUpper c : cs + in Prop [ mkConstMethod_ name np t + , mkMethod_ setName [t] Internal_TVoid + ] + +-- | Creates a getter/setter binding pair for static methods: +-- +-- > static T foo() const +-- > static void setFoo(T) +mkStaticProp :: String -> Type -> ClassEntity +mkStaticProp = (CEProp .) . mkStaticProp_ + +-- | The unwrapped version of 'mkStaticProp'. +mkStaticProp_ :: String -> Type -> Prop +mkStaticProp_ name t = + let c:cs = name + setName = 's' : 'e' : 't' : toUpper c : cs + in Prop [ mkStaticMethod_ name np t + , mkStaticMethod_ setName [t] Internal_TVoid + ] + +-- | Creates a getter/setter binding pair for boolean methods, where the getter +-- is prefixed with @is@: +-- +-- > bool isFoo() const +-- > void setFoo(bool) +-- +-- The result is wrapped in a 'CEProp'. For an unwrapped value, use +-- 'mkBoolIsProp_'. +mkBoolIsProp :: String -> ClassEntity +mkBoolIsProp = CEProp . mkBoolIsProp_ + +-- | The unwrapped version of 'mkBoolIsProp'. +mkBoolIsProp_ :: String -> Prop +mkBoolIsProp_ name = + let c:cs = name + name' = toUpper c : cs + isName = 'i':'s':name' + setName = 's':'e':'t':name' + in Prop [ mkConstMethod_ isName np boolT + , mkMethod_ setName [boolT] voidT + ] + +-- | Creates a getter/setter binding pair for boolean methods, where the getter +-- is prefixed with @has@: +-- +-- > bool hasFoo() const +-- > void setFoo(bool) +-- +-- The result is wrapped in a 'CEProp'. For an unwrapped value, use +-- 'mkBoolHasProp_'. +mkBoolHasProp :: String -> ClassEntity +mkBoolHasProp = CEProp . mkBoolHasProp_ + +-- | The unwrapped version of 'mkBoolHasProp'. +mkBoolHasProp_ :: String -> Prop +mkBoolHasProp_ name = + let c:cs = name + name' = toUpper c : cs + hasName = 'h':'a':'s':name' + setName = 's':'e':'t':name' + in Prop [ mkConstMethod_ hasName np boolT + , mkMethod_ setName [boolT] voidT + ] + +sayCppExport :: LC.SayExportMode -> Class -> LC.Generator () +sayCppExport mode cls = case mode of + LC.SayHeader -> return () + LC.SaySource -> do + let clsPtr = ptrT $ objT cls + constClsPtr = ptrT $ constT $ objT cls + -- TODO Is this redundant for a completely empty class? (No ctors or methods, private dtor.) + LC.addReqsM $ classReqs cls -- This is needed at least for the delete function. + + -- Export each of the class's constructors. + forM_ (classCtors cls) $ \ctor -> + Function.sayCppExportFn + (classEntityExtName cls ctor) + (Function.CallFn $ LC.say "new" >> LC.sayIdentifier (classIdentifier cls)) + Nothing + (ctorParams ctor) + clsPtr + (ctorExceptionHandlers ctor) + True -- Render the body. + + -- Export a delete function for the class. + when (classDtorIsPublic cls) $ + LC.sayFunction (cppDeleteFnName cls) + ["self"] + (fnT [constClsPtr] voidT) $ + Just $ LC.say "delete self;\n" + + -- Export each of the class's variables. + forM_ (classVariables cls) $ sayCppExportClassVar cls + + -- Export each of the class's methods. + forM_ (classMethods cls) $ \method -> do + let static = case methodStatic method of + Static -> True + Nonstatic -> False + thisType = case methodConst method of + Const -> constClsPtr + Nonconst -> clsPtr + nonMemberCall = static || case methodImpl method of + RealMethod {} -> False + FnMethod {} -> True + Function.sayCppExportFn + (classEntityExtName cls method) + (case methodImpl method of + RealMethod name -> case name of + FnName cName -> Function.CallFn $ do + when static $ do + LC.sayIdentifier (classIdentifier cls) + LC.say "::" + LC.say cName + FnOp op -> Function.CallOp op + FnMethod name -> case name of + FnName cName -> Function.CallFn $ LC.sayIdentifier cName + FnOp op -> Function.CallOp op) + (if nonMemberCall then Nothing else Just thisType) + (methodParams method) + (methodReturn method) + (methodExceptionHandlers method) + True -- Render the body. + + -- Export upcast functions for the class to its direct superclasses. + forM_ (classSuperclasses cls) $ genUpcastFns cls + -- Export downcast functions from the class's direct and indirect + -- superclasses to it. + unless (classIsSubclassOfMonomorphic cls) $ + forM_ (classSuperclasses cls) $ genDowncastFns cls + + where genUpcastFns :: Class -> Class -> LC.Generator () + genUpcastFns cls' ancestorCls = do + LC.sayFunction (cppCastFnName cls' ancestorCls) + ["self"] + (fnT [ptrT $ constT $ objT cls'] $ ptrT $ constT $ objT ancestorCls) + (Just $ LC.say "return self;\n") + forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls' + + genDowncastFns :: Class -> Class -> LC.Generator () + genDowncastFns cls' ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do + let clsPtr = ptrT $ constT $ objT cls' + ancestorPtr = ptrT $ constT $ objT ancestorCls + LC.sayFunction (cppCastFnName ancestorCls cls') + ["self"] + (fnT [ancestorPtr] clsPtr) $ Just $ do + LC.say "return dynamic_cast<" + LC.sayType Nothing clsPtr + LC.say ">(self);\n" + forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls' + +sayCppExportClassVar :: Class -> ClassVariable -> LC.Generator () +sayCppExportClassVar cls v = + sayCppExportVar (classVarType v) + (case classVarStatic v of + Nonstatic -> Just (ptrT $ constT $ objT cls, ptrT $ objT cls) + Static -> Nothing) + (classVarGettable v) + (classVarGetterExtName cls v) + (classVarSetterExtName cls v) + (case classVarStatic v of + Nonstatic -> LC.say $ classVarCName v + Static -> do LC.sayIdentifier $ classIdentifier cls + LC.says ["::", classVarCName v]) + +makeClassCppName :: String -> Class -> String +makeClassCppName prefix cls = LC.makeCppName [prefix, fromExtName $ classExtName cls] + +-- | \"gendel\" is the prefix used for wrappers for @delete@ calls. +cppDeleteFnPrefix :: String +cppDeleteFnPrefix = "gendel" + +-- | Returns the C++ binding function name of the wrapper for the delete method +-- for a class. +cppDeleteFnName :: Class -> String +cppDeleteFnName = makeClassCppName cppDeleteFnPrefix + +-- | @cppCastFnName fromCls toCls@ returns the name of the generated C++ +-- function that casts a pointer from @fromCls@ to @toCls@. +cppCastFnName :: Class -> Class -> String +cppCastFnName from to = + concat [ "gencast__" + , fromExtName $ classExtName from + , "__" + , fromExtName $ classExtName to + ] + +sayHsExport :: LH.SayExportMode -> Class -> LH.Generator () +sayHsExport mode cls = LH.withErrorContext ("generating class " ++ show (classExtName cls)) $ do + case mode of + LH.SayExportForeignImports -> do + sayHsExportClassVars mode cls + sayHsExportClassCtors mode cls + + forM_ (classMethods cls) $ \method -> + (Function.sayHsExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*> + methodPurity <*> pure (getMethodEffectiveParams cls method) <*> + methodReturn <*> methodExceptionHandlers) + method + + LH.SayExportDecls -> do + sayHsExportClassClass True cls Const + sayHsExportClassClass True cls Nonconst + + sayHsExportClassStaticMethods cls + + -- Create a newtype for referencing foreign objects with pointers. The + -- newtype is not used with encodings of value objects. + sayHsExportClassDataType True cls Const + sayHsExportClassDataType True cls Nonconst + + sayHsExportClassExceptionSupport True cls + + sayHsExportClassVars mode cls + sayHsExportClassCtors mode cls + + LH.SayExportBoot -> do + sayHsExportClassClass False cls Const + sayHsExportClassClass False cls Nonconst + + sayHsExportClassDataType False cls Const + sayHsExportClassDataType False cls Nonconst + + sayHsExportClassExceptionSupport False cls + + sayHsExportClassVars mode cls + + sayHsExportClassCastPrimitives mode cls + sayHsExportClassSpecialFns mode cls + +sayHsExportClassClass :: Bool -> Class -> Constness -> LH.Generator () +sayHsExportClassClass doDecls cls cst = LH.withErrorContext "generating Haskell typeclass" $ do + hsTypeName <- toHsDataTypeName cst cls + hsValueClassName <- toHsValueClassName cls + hsWithValuePtrName <- toHsWithValuePtrName cls + hsPtrClassName <- toHsPtrClassName cst cls + hsCastMethodName <- toHsCastMethodName cst cls + let supers = classSuperclasses cls + + hsSupers <- + (\x -> if null x + then do LH.addImports hsImportForRuntime + return ["HoppyFHR.CppPtr"] + else return x) =<< + case cst of + Const -> mapM (toHsPtrClassName Const) supers + Nonconst -> + (:) <$> toHsPtrClassName Const cls <*> mapM (toHsPtrClassName Nonconst) supers + + -- Print the value class definition. There is only one of these, and it is + -- spiritually closer to the const version of the pointers for this class, so + -- we emit for the const case only. + when (cst == Const) $ do + LH.addImports hsImportForPrelude + LH.addExport' hsValueClassName + LH.ln + LH.saysLn ["class ", hsValueClassName, " a where"] + LH.indent $ + LH.saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"] + + -- Generate instances for all pointer subtypes. + LH.ln + LH.saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a", + if doDecls then " where" else ""] + when doDecls $ do + LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"], + hsImportForPrelude] + LH.indent $ LH.saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName] + + -- When the class is encodable to a native Haskell type, also print an + -- instance for it. + let conv = LH.getClassHaskellConversion cls + case (classHaskellConversionType conv, + classHaskellConversionToCppFn conv) of + (Just hsTypeGen, Just _) -> do + hsType <- hsTypeGen + LH.ln + LH.saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, + " (", LH.prettyPrint hsType, ")", if doDecls then " where" else ""] + when doDecls $ do + LH.addImports hsImportForRuntime + LH.indent $ LH.saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"] + _ -> return () + + -- Print the pointer class definition. + LH.addExport' hsPtrClassName + LH.ln + LH.saysLn $ + "class (" : + intersperse ", " (map (++ " this") hsSupers) ++ + [") => ", hsPtrClassName, " this where"] + LH.indent $ LH.saysLn [hsCastMethodName, " :: this -> ", hsTypeName] + + -- Print the non-static methods. + when doDecls $ do + let methods = filter ((cst ==) . methodConst) $ classMethods cls + forM_ methods $ \method -> + when (methodStatic method == Nonstatic) $ + (Function.sayHsExportFn LH.SayExportDecls <$> + classEntityExtName cls <*> classEntityForeignName cls <*> + methodPurity <*> pure (getMethodEffectiveParams cls method) <*> + methodReturn <*> methodExceptionHandlers) method + +sayHsExportClassStaticMethods :: Class -> LH.Generator () +sayHsExportClassStaticMethods cls = + forM_ (classMethods cls) $ \method -> + when (methodStatic method == Static) $ + (Function.sayHsExportFn LH.SayExportDecls <$> + classEntityExtName cls <*> classEntityForeignName cls <*> + methodPurity <*> methodParams <*> methodReturn <*> methodExceptionHandlers) method + +sayHsExportClassDataType :: Bool -> Class -> Constness -> LH.Generator () +sayHsExportClassDataType doDecls cls cst = LH.withErrorContext "generating Haskell data types" $ do + hsTypeName <- toHsDataTypeName cst cls + hsCtor <- toHsDataCtorName LH.Unmanaged cst cls + hsCtorGc <- toHsDataCtorName LH.Managed cst cls + constCastFnName <- toHsConstCastFnName cst cls + + LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime] + -- Unfortunately, we must export the data constructor, so that GHC can marshal + -- it in foreign calls in other modules. + LH.addExport' hsTypeName + LH.ln + LH.saysLn ["data ", hsTypeName, " ="] + LH.indent $ do + LH.saysLn [" ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"] + LH.saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"] + when doDecls $ do + LH.addImports $ hsImport1 "Prelude" "(==)" + LH.indent $ LH.sayLn "deriving (HoppyP.Show)" + LH.ln + LH.saysLn ["instance HoppyP.Eq ", hsTypeName, " where"] + LH.indent $ LH.saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"] + LH.ln + LH.saysLn ["instance HoppyP.Ord ", hsTypeName, " where"] + LH.indent $ LH.saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"] + + -- Generate const_cast functions: + -- castFooToConst :: Foo -> FooConst + -- castFooToNonconst :: FooConst -> Foo + hsTypeNameOppConst <- toHsDataTypeName (constNegate cst) cls + LH.ln + LH.addExport constCastFnName + LH.saysLn [constCastFnName, " :: ", hsTypeNameOppConst, " -> ", hsTypeName] + when doDecls $ do + LH.addImports $ hsImport1 "Prelude" "($)" + hsCtorOppConst <- toHsDataCtorName LH.Unmanaged (constNegate cst) cls + hsCtorGcOppConst <- toHsDataCtorName LH.Managed (constNegate cst) cls + LH.saysLn [constCastFnName, " (", hsCtorOppConst, + " ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"] + LH.saysLn [constCastFnName, " (", hsCtorGcOppConst, + " fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"] + + -- Generate an instance of CppPtr. + LH.ln + if doDecls + then do LH.addImports $ hsImport1 "Prelude" "($)" + LH.saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"] + LH.indent $ do + LH.saysLn ["nullptr = ", hsCtor, " HoppyF.nullPtr"] + LH.ln + LH.saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"] + LH.saysLn ["withCppPtr (", hsCtorGc, + " fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"] + LH.ln + LH.saysLn ["toPtr (", hsCtor, " ptr') = ptr'"] + LH.saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"] + LH.ln + LH.saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"] + LH.saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"] + + when (classDtorIsPublic cls) $ do + LH.addImports $ hsImport1 "Prelude" "(==)" + LH.ln + LH.saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"] + LH.indent $ do + -- Note, similar "delete" and "toGc" functions are generated for exception + -- classes' ExceptionClassInfo structures. + case cst of + Const -> + LH.saysLn ["delete (", hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, " ptr'"] + Nonconst -> do + constTypeName <- toHsDataTypeName Const cls + LH.saysLn ["delete (",hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, + " $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", constTypeName, ")"] + LH.saysLn ["delete (", hsCtorGc, + " _ _) = HoppyP.fail $ HoppyP.concat ", + "[\"Deletable.delete: Asked to delete a GC-managed \", ", + show hsTypeName, ", \" object.\"]"] + LH.ln + LH.saysLn ["toGc this'@(", hsCtor, " ptr') = ", + -- No sense in creating a ForeignPtr for a null pointer. + "if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ", + "(HoppyP.flip ", hsCtorGc, " ptr') $ ", + "HoppyF.newForeignPtr ", + -- The foreign delete function takes a const pointer; we cast it to + -- take a Ptr () to match up with the ForeignPtr () we're creating, + -- assuming that data pointers have the same representation. + "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls, + " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ", + "(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"] + LH.saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"] + + forM_ (classFindCopyCtor cls) $ \copyCtor -> do + copyCtorName <- toHsCtorName cls copyCtor + LH.ln + LH.saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ", + case cst of + Nonconst -> hsTypeName + Const -> hsTypeNameOppConst, + " where copy = ", copyCtorName] + + else do LH.saysLn ["instance HoppyFHR.CppPtr ", hsTypeName] + + when (classDtorIsPublic cls) $ + LH.saysLn ["instance HoppyFHR.Deletable ", hsTypeName] + + forM_ (classFindCopyCtor cls) $ \_ -> + LH.saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ", + case cst of + Nonconst -> hsTypeName + Const -> hsTypeNameOppConst] + + -- Generate instances for all superclasses' typeclasses. + genInstances hsTypeName [] cls + + where genInstances :: String -> [Class] -> Class -> LH.Generator () + genInstances hsTypeName path ancestorCls = do + -- In this example Bar inherits from Foo. We are generating instances + -- either for BarConst or Bar, depending on 'cst'. + -- + -- BarConst's instances: + -- instance FooConstPtr BarConst where + -- toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr' + -- toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr' + -- + -- instance BarConstPtr BarConst where + -- toFooConst = id + -- + -- Bar's instances: + -- instance FooConstPtr Bar + -- toFooConst (Bar ptr') = + -- FooConst $ castBarToFoo $ castBarToConst ptr' + -- toFooConst (BarGc fptr' ptr') = + -- FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr' + -- + -- instance FooPtr Bar + -- toFoo (Bar ptr') = + -- Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' + -- toFoo (BarGc fptr' ptr') = + -- FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' + -- + -- instance BarConstPtr Bar + -- toBarConst (Bar ptr') = Bar $ castBarToConst ptr' + -- toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr' + -- + -- instance BarPtr Bar + -- toBar = id + -- + -- In all cases, we unwrap the pointer, maybe add const, maybe do an + -- upcast, maybe remove const, then rewrap the pointer. The identity + -- cases are where we just unwrap and wrap again. + + forM_ (case cst of + Const -> [Const] + Nonconst -> [Const, Nonconst]) $ \ancestorCst -> do + LH.ln + ancestorPtrClassName <- toHsPtrClassName ancestorCst ancestorCls + LH.saysLn ["instance ", ancestorPtrClassName, " ", hsTypeName, + if doDecls then " where" else ""] + when doDecls $ LH.indent $ do + -- Unqualified, for Haskell instance methods. + let castMethodName = toHsCastMethodName' ancestorCst ancestorCls + if null path && cst == ancestorCst + then do LH.addImports hsImportForPrelude + LH.saysLn [castMethodName, " = HoppyP.id"] + else do let addConst = cst == Nonconst + removeConst = ancestorCst == Nonconst + when (addConst || removeConst) $ + LH.addImports hsImportForForeign + forM_ ([minBound..] :: [LH.Managed]) $ \managed -> do + ancestorCtor <- case managed of + LH.Unmanaged -> (\x -> [x]) <$> + toHsDataCtorName LH.Unmanaged ancestorCst ancestorCls + LH.Managed -> (\x -> [x, " fptr'"]) <$> + toHsDataCtorName LH.Managed ancestorCst ancestorCls + ptrPattern <- case managed of + LH.Unmanaged -> (\x -> [x, " ptr'"]) <$> + toHsDataCtorName LH.Unmanaged cst cls + LH.Managed -> (\x -> [x, " fptr' ptr'"]) <$> + toHsDataCtorName LH.Managed cst cls + LH.saysLn . concat =<< sequence + [ return $ + [castMethodName, " ("] ++ ptrPattern ++ [") = "] ++ ancestorCtor + , if removeConst + then do ancestorConstType <- toHsDataTypeName Const ancestorCls + ancestorNonconstType <- toHsDataTypeName Nonconst ancestorCls + return [" $ (HoppyF.castPtr :: HoppyF.Ptr ", + ancestorConstType, " -> HoppyF.Ptr ", + ancestorNonconstType, ")"] + else return [] + , if not $ null path + then do LH.addImports $ hsImport1 "Prelude" "($)" + castPrimitiveName <- toHsCastPrimitiveName cls cls ancestorCls + return [" $ ", castPrimitiveName] + else return [] + , if addConst + then do LH.addImports $ hsImport1 "Prelude" "($)" + nonconstTypeName <- toHsDataTypeName Nonconst cls + constTypeName <- toHsDataTypeName Const cls + return [" $ (HoppyF.castPtr :: HoppyF.Ptr ", + nonconstTypeName, " -> HoppyF.Ptr ", + constTypeName, ")"] + else return [] + , return [" ptr'"] + ] + + forM_ (classSuperclasses ancestorCls) $ + genInstances hsTypeName $ + ancestorCls : path + +sayHsExportClassVars :: LH.SayExportMode -> Class -> LH.Generator () +sayHsExportClassVars mode cls = + forM_ (classVariables cls) $ sayHsExportClassVar mode cls + +sayHsExportClassVar :: LH.SayExportMode -> Class -> ClassVariable -> LH.Generator () +sayHsExportClassVar mode cls v = + LH.withErrorContext ("generating variable " ++ show (classVarExtName v)) $ + sayHsExportVar mode + (classVarType v) + (case classVarStatic v of + Nonstatic -> Just cls + Static -> Nothing) + (classVarGettable v) + (classVarGetterExtName cls v) + (classVarGetterForeignName cls v) + (classVarSetterExtName cls v) + (classVarSetterForeignName cls v) + +sayHsExportClassCtors :: LH.SayExportMode -> Class -> LH.Generator () +sayHsExportClassCtors mode cls = + LH.withErrorContext "generating constructors" $ + forM_ (classCtors cls) $ \ctor -> + (Function.sayHsExportFn mode <$> + classEntityExtName cls <*> classEntityForeignName cls <*> + pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls) <*> + ctorExceptionHandlers) ctor + +sayHsExportClassSpecialFns :: LH.SayExportMode -> Class -> LH.Generator () +sayHsExportClassSpecialFns mode cls = do + typeName <- toHsDataTypeName Nonconst cls + typeNameConst <- toHsDataTypeName Const cls + + -- Say the delete function. + LH.withErrorContext "generating delete bindings" $ + case mode of + LH.SayExportForeignImports -> when (classDtorIsPublic cls) $ do + LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude] + LH.saysLn ["foreign import ccall \"", cppDeleteFnName cls, "\" ", + toHsClassDeleteFnName' cls, " :: HoppyF.Ptr ", + typeNameConst, " -> HoppyP.IO ()"] + LH.saysLn ["foreign import ccall \"&", cppDeleteFnName cls, "\" ", + toHsClassDeleteFnPtrName' cls, " :: HoppyF.FunPtr (HoppyF.Ptr ", + typeNameConst, " -> HoppyP.IO ())"] + -- The user interface to this is the generic 'delete' function, rendered + -- elsewhere. + LH.SayExportDecls -> return () + LH.SayExportBoot -> return () + + LH.withErrorContext "generating pointer Assignable instance" $ + case mode of + LH.SayExportForeignImports -> return () + LH.SayExportDecls -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForForeign, + hsImportForRuntime] + LH.ln + LH.saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", + typeName, " where"] + LH.indent $ LH.sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'" + LH.SayExportBoot -> return () + + -- If the class has an assignment operator that takes its own type, then + -- generate an instance of Assignable. + LH.withErrorContext "generating Assignable instance" $ do + let assignmentMethods = flip filter (classMethods cls) $ \m -> + let paramTypes = map parameterType $ methodParams m + in methodApplicability m == MNormal && + (paramTypes == [objT cls] || paramTypes == [refT $ constT $ objT cls]) && + (case methodImpl m of + RealMethod name -> name == FnOp OpAssign + FnMethod name -> name == FnOp OpAssign) + withAssignmentMethod f = case assignmentMethods of + [] -> return () + [m] -> f m + _ -> + throwError $ concat + ["Can't determine an Assignable instance to generator for ", show cls, + " because it has multiple assignment operators ", show assignmentMethods] + when (mode == LH.SayExportDecls) $ withAssignmentMethod $ \m -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude] + valueClassName <- toHsValueClassName cls + assignmentMethodName <- toHsMethodName cls m + LH.ln + LH.saysLn ["instance ", valueClassName, " a => HoppyFHR.Assignable ", typeName, " a where"] + LH.indent $ + LH.saysLn ["assign x' y' = ", assignmentMethodName, " x' y' >> HoppyP.return ()"] + + -- A pointer to an object pointer is decodable to an object pointer by peeking + -- at the value, so generate a Decodable instance. You are now a two-star + -- programmer. There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which + -- handles deeper levels. + LH.withErrorContext "generating pointer Decodable instance" $ do + case mode of + LH.SayExportForeignImports -> return () + + LH.SayExportDecls -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForForeign, + hsImportForPrelude, + hsImportForRuntime] + LH.ln + LH.saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", + typeName, ")) ", typeName, " where"] + LH.indent $ do + ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls + LH.saysLn ["decode = HoppyP.fmap ", ctorName, " . HoppyF.peek"] + + LH.SayExportBoot -> do + LH.addImports $ mconcat [hsImportForForeign, hsImportForRuntime] + LH.ln + -- TODO Encodable. + LH.saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", + typeName] + + -- Say Encodable and Decodable instances, if the class is encodable and + -- decodable. + LH.withErrorContext "generating Encodable/Decodable instances" $ do + let conv = LH.getClassHaskellConversion cls + forM_ (classHaskellConversionType conv) $ \hsTypeGen -> do + let hsTypeStrGen = hsTypeGen >>= \hsType -> return $ "(" ++ LH.prettyPrint hsType ++ ")" + + case mode of + LH.SayExportForeignImports -> return () + + LH.SayExportDecls -> do + -- Say the Encodable instances. + forM_ (classHaskellConversionToCppFn conv) $ \toCppFnGen -> do + hsTypeStr <- hsTypeStrGen + LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + castMethodName <- toHsCastMethodName Const cls + + LH.ln + LH.saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"] + LH.indent $ do + LH.sayLn "encode =" + LH.indent toCppFnGen + LH.ln + LH.saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"] + LH.indent $ + LH.saysLn ["encode = HoppyP.fmap (", castMethodName, + ") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"] + + -- Say the Decodable instances. + forM_ (classHaskellConversionFromCppFn conv) $ \fromCppFnGen -> do + hsTypeStr <- hsTypeStrGen + LH.addImports hsImportForRuntime + castMethodName <- toHsCastMethodName Const cls + + LH.ln + LH.saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"] + LH.indent $ + LH.saysLn ["decode = HoppyFHR.decode . ", castMethodName] + LH.ln + LH.saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"] + LH.indent $ do + LH.sayLn "decode =" + LH.indent fromCppFnGen + + LH.SayExportBoot -> do + -- Say the Encodable instances. + forM_ (classHaskellConversionToCppFn conv) $ \_ -> do + hsTypeStr <- hsTypeStrGen + LH.addImports hsImportForRuntime + LH.ln + LH.saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"] + LH.saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"] + + -- Say the Decodable instances. + forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do + hsTypeStr <- hsTypeStrGen + LH.addImports hsImportForRuntime + LH.ln + LH.saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"] + LH.saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"] + +-- | Generates a non-const @CppException@ instance if the class is an exception +-- class. +sayHsExportClassExceptionSupport :: Bool -> Class -> LH.Generator () +sayHsExportClassExceptionSupport doDecls cls = + when (classIsException cls) $ + LH.withErrorContext "generating exception support" $ do + typeName <- toHsDataTypeName Nonconst cls + typeNameConst <- toHsDataTypeName Const cls + + -- Generate a non-const CppException instance. + exceptionId <- getHsClassExceptionId cls + LH.addImports hsImportForRuntime + LH.ln + LH.saysLn ["instance HoppyFHR.CppException ", typeName, + if doDecls then " where" else ""] + when doDecls $ LH.indent $ do + ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls + ctorGcName <- toHsDataCtorName LH.Managed Nonconst cls + LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)", "(=<<)"], + hsImportForForeign, + hsImportForMap, + hsImportForPrelude] + LH.sayLn "cppExceptionInfo _ =" + LH.indent $ do + LH.saysLn ["HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ", + show $ getExceptionId exceptionId, ") ", show typeName, + " upcasts' delete' copy' toGc'"] + + -- Note, similar "delete" and "toGc" functions are generated for the class's + -- Deletable instance. + LH.saysLn ["where delete' ptr' = ", toHsClassDeleteFnName' cls, + " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeNameConst, ")"] + + LH.indentSpaces 6 $ do + LH.ln + LH.saysLn ["copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ", + ctorName, " . HoppyF.castPtr"] + + LH.ln + LH.saysLn ["toGc' ptr' = HoppyF.newForeignPtr ", + -- The foreign delete function takes a const pointer; we cast it to + -- take a Ptr () to match up with the ForeignPtr () we're creating, + -- assuming that data pointers have the same representation. + "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls, + " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ", + "ptr'"] + + LH.sayLn "upcasts' = HoppyDM.fromList" + LH.indent $ case classSuperclasses cls of + [] -> LH.sayLn "[]" + _ -> do + let genCast :: Bool -> [Class] -> Class -> LH.Generator () + genCast first path ancestorCls = + when (classIsException ancestorCls) $ do + let path' = ancestorCls : path + ancestorId <- getHsClassExceptionId ancestorCls + ancestorCastChain <- forM (zip path' $ drop 1 path') $ \(to, from) -> + -- We're upcasting, so 'from' is the subclass. + toHsCastPrimitiveName from from to + LH.saysLn $ concat [ [if first then "[" else ",", + " ( HoppyFHR.ExceptionId ", + show $ getExceptionId ancestorId, + ", \\(e' :: HoppyF.Ptr ()) -> "] + , intersperse " $ " $ + "HoppyF.castPtr" : + ancestorCastChain ++ + ["HoppyF.castPtr e' :: HoppyF.Ptr ()"] + , [")"] + ] + forM_ (classSuperclasses ancestorCls) $ genCast False path' + + forM_ (zip (classSuperclasses cls) (True : repeat False)) $ + \(ancestorCls, first) -> genCast first [cls] ancestorCls + LH.sayLn "]" + + LH.ln + LH.saysLn ["cppExceptionBuild fptr' ptr' = ", ctorGcName, + " fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"] + LH.ln + LH.saysLn ["cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ctorName, + " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"] + + -- Generate a const CppException instance that piggybacks off of the + -- non-const implementation. + LH.ln + LH.saysLn ["instance HoppyFHR.CppException ", typeNameConst, + if doDecls then " where" else ""] + when doDecls $ LH.indent $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude] + constCastFnName <- toHsConstCastFnName Const cls + LH.saysLn ["cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ", + typeName, ")"] + LH.saysLn ["cppExceptionBuild = (", constCastFnName, + " .) . HoppyFHR.cppExceptionBuild"] + LH.saysLn ["cppExceptionBuildToGc = HoppyP.fmap ", constCastFnName, + " . HoppyFHR.cppExceptionBuildToGc"] + + -- Generate a non-const CppThrowable instance. + LH.ln + LH.saysLn ["instance HoppyFHR.CppThrowable ", typeName, + if doDecls then " where" else ""] + when doDecls $ LH.indent $ do + ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls + ctorGcName <- toHsDataCtorName LH.Managed Nonconst cls + LH.addImports $ mconcat [hsImportForForeign, + hsImportForPrelude] + LH.saysLn ["toSomeCppException this'@(", ctorName, " ptr') = ", + "HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') HoppyP.Nothing ", + "(HoppyF.castPtr ptr')"] + LH.saysLn ["toSomeCppException this'@(", ctorGcName, " fptr' ptr') = ", + "HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') ", + "(HoppyF.castPtr ptr')"] + +sayHsExportClassCastPrimitives :: LH.SayExportMode -> Class -> LH.Generator () +sayHsExportClassCastPrimitives mode cls = LH.withErrorContext "generating cast primitives" $ do + clsType <- toHsDataTypeName Const cls + case mode of + LH.SayExportForeignImports -> + forAncestors cls $ \super -> do + hsCastFnName <- toHsCastPrimitiveName cls cls super + hsDownCastFnName <- toHsCastPrimitiveName cls super cls + superType <- toHsDataTypeName Const super + LH.addImports hsImportForForeign + LH.addExport hsCastFnName + LH.saysLn [ "foreign import ccall \"", cppCastFnName cls super + , "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType + ] + unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do + LH.addExport hsDownCastFnName + LH.saysLn [ "foreign import ccall \"", cppCastFnName super cls + , "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr " + , clsType + ] + return True + + LH.SayExportDecls -> + -- Generate a downcast typeclass and instances for all ancestor classes + -- for the current constness. These don't need to be in the boot file, + -- since they're not used by other generated bindings. + unless (classIsSubclassOfMonomorphic cls) $ + forM_ [minBound..] $ \cst -> do + downCastClassName <- toHsDownCastClassName cst cls + downCastMethodName <- toHsDownCastMethodName cst cls + typeName <- toHsDataTypeName cst cls + LH.addExport' downCastClassName + LH.ln + LH.saysLn ["class ", downCastClassName, " a where"] + LH.indent $ LH.saysLn [downCastMethodName, " :: ", + LH.prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $ + HsTyCon $ UnQual $ HsIdent typeName] + LH.ln + forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of + True -> return False + False -> do + superTypeName <- toHsDataTypeName cst super + primitiveCastFn <- toHsCastPrimitiveName cls super cls + LH.saysLn ["instance ", downCastClassName, " ", superTypeName, " where"] + + -- If Foo is a superclass of Bar: + -- + -- instance BarSuper Foo where + -- downToBar castFooToNonconst . downcast' . castFooToConst + -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' + -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' + -- + -- instance BarSuperConst FooConst where + -- downToBarConst = downcast' + -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' + -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' + + LH.indent $ do + case cst of + Const -> LH.saysLn [downCastMethodName, " = cast'"] + Nonconst -> do + LH.addImports $ hsImport1 "Prelude" "(.)" + castClsToNonconst <- toHsConstCastFnName Nonconst cls + castSuperToConst <- toHsConstCastFnName Const super + LH.saysLn [downCastMethodName, " = ", castClsToNonconst, " . cast' . ", + castSuperToConst] + LH.indent $ do + LH.sayLn "where" + LH.indent $ do + clsCtorName <- toHsDataCtorName LH.Unmanaged Const cls + clsCtorGcName <- toHsDataCtorName LH.Managed Const cls + superCtorName <- toHsDataCtorName LH.Unmanaged Const super + superCtorGcName <- toHsDataCtorName LH.Managed Const super + LH.saysLn ["cast' (", superCtorName, " ptr') = ", + clsCtorName, " $ ", primitiveCastFn, " ptr'"] + LH.saysLn ["cast' (", superCtorGcName, " fptr' ptr') = ", + clsCtorGcName , " fptr' $ ", primitiveCastFn, " ptr'"] + return True + + LH.SayExportBoot -> do + forAncestors cls $ \super -> do + hsCastFnName <- toHsCastPrimitiveName cls cls super + superType <- toHsDataTypeName Const super + LH.addImports hsImportForForeign + LH.addExport hsCastFnName + LH.saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType] + return True + + where forAncestors :: Class -> (Class -> LH.Generator Bool) -> LH.Generator () + forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do + recur <- f super + when recur $ forAncestors super f + +getMethodEffectiveParams :: Class -> Method -> [Parameter] +getMethodEffectiveParams cls method = + (case methodImpl method of + RealMethod {} -> case methodApplicability method of + MNormal -> (("this" ~: ptrT $ objT cls) :) + MConst -> (("this" ~: ptrT $ constT $ objT cls) :) + MStatic -> id + FnMethod {} -> id) $ + methodParams method + +getHsClassExceptionId :: Class -> LH.Generator ExceptionId +getHsClassExceptionId cls = do + iface <- LH.askInterface + fromMaybeM (throwError $ concat + ["Internal error, exception class ", show cls, " doesn't have an exception ID"]) $ + interfaceExceptionClassId iface cls + +-- | The name for the typeclass of types that can be represented as values of +-- the given C++ class. +toHsValueClassName :: Class -> LH.Generator String +toHsValueClassName cls = + LH.inFunction "toHsValueClassName" $ + LH.addExtNameModule (classExtName cls) $ toHsValueClassName' cls + +-- | Pure version of 'toHsValueClassName' that doesn't create a qualified name. +toHsValueClassName' :: Class -> String +toHsValueClassName' cls = toHsDataTypeName' Nonconst cls ++ "Value" + +-- | The name of the method within the 'toHsValueClassName' typeclass for +-- accessing an object of the type as a pointer. +toHsWithValuePtrName :: Class -> LH.Generator String +toHsWithValuePtrName cls = + LH.inFunction "toHsWithValuePtrName" $ + LH.addExtNameModule (classExtName cls) $ toHsWithValuePtrName' cls + +-- | Pure version of 'toHsWithValuePtrName' that doesn't create a qualified name. +toHsWithValuePtrName' :: Class -> String +toHsWithValuePtrName' cls = concat ["with", toHsDataTypeName' Nonconst cls, "Ptr"] + +-- | The name for the typeclass of types that are (possibly const) pointers to +-- objects of the given C++ class, or subclasses. +toHsPtrClassName :: Constness -> Class -> LH.Generator String +toHsPtrClassName cst cls = + LH.inFunction "toHsPtrClassName" $ + LH.addExtNameModule (classExtName cls) $ toHsPtrClassName' cst cls + +-- | Pure version of 'toHsPtrClassName' that doesn't create a qualified name. +toHsPtrClassName' :: Constness -> Class -> String +toHsPtrClassName' cst cls = toHsDataTypeName' cst cls ++ "Ptr" + +-- | The name of the function that upcasts pointers to the specific class type +-- and constness. +toHsCastMethodName :: Constness -> Class -> LH.Generator String +toHsCastMethodName cst cls = + LH.inFunction "toHsCastMethodName" $ + LH.addExtNameModule (classExtName cls) $ toHsCastMethodName' cst cls + +-- | Pure version of 'toHsCastMethodName' that doesn't create a qualified name. +toHsCastMethodName' :: Constness -> Class -> String +toHsCastMethodName' cst cls = "to" ++ toHsDataTypeName' cst cls + +-- | The name of the typeclass that provides a method to downcast to a specific +-- class type. See 'toHsDownCastMethodName'. +toHsDownCastClassName :: Constness -> Class -> LH.Generator String +toHsDownCastClassName cst cls = + LH.inFunction "toHsDownCastClassName" $ + LH.addExtNameModule (classExtName cls) $ toHsDownCastClassName' cst cls + +-- | Pure version of 'toHsDownCastClassName' that doesn't create a qualified +-- name. +toHsDownCastClassName' :: Constness -> Class -> String +toHsDownCastClassName' cst cls = + concat [toHsDataTypeName' Nonconst cls, + "Super", + case cst of + Const -> "Const" + Nonconst -> ""] + +-- | The name of the function that downcasts pointers to the specific class type +-- and constness. +toHsDownCastMethodName :: Constness -> Class -> LH.Generator String +toHsDownCastMethodName cst cls = + LH.inFunction "toHsDownCastMethodName" $ + LH.addExtNameModule (classExtName cls) $ toHsDownCastMethodName' cst cls + +-- | Pure version of 'toHsDownCastMethodName' that doesn't create a qualified +-- name. +toHsDownCastMethodName' :: Constness -> Class -> String +toHsDownCastMethodName' cst cls = "downTo" ++ toHsDataTypeName' cst cls + +-- | The import name for the foreign function that casts between two specific +-- pointer types. Used for upcasting and downcasting. +-- +-- We need to know which module the cast function resides in, and while we could +-- look this up, the caller always knows, so we just have them pass it in. +toHsCastPrimitiveName :: Class -> Class -> Class -> LH.Generator String +toHsCastPrimitiveName descendentClass from to = + LH.inFunction "toHsCastPrimitiveName" $ + LH.addExtNameModule (classExtName descendentClass) $ toHsCastPrimitiveName' from to + +-- | Pure version of 'toHsCastPrimitiveName' that doesn't create a qualified +-- name. +toHsCastPrimitiveName' :: Class -> Class -> String +toHsCastPrimitiveName' from to = + concat ["cast", toHsDataTypeName' Nonconst from, "To", toHsDataTypeName' Nonconst to] + +-- | The name of one of the functions that add/remove const to/from a class's +-- pointer type. Given 'Const', it will return the function that adds const, +-- and given 'Nonconst', it will return the function that removes const. +toHsConstCastFnName :: Constness -> Class -> LH.Generator String +toHsConstCastFnName cst cls = + LH.inFunction "toHsConstCastFnName" $ + LH.addExtNameModule (classExtName cls) $ toHsConstCastFnName' cst cls + +-- | Pure version of 'toHsConstCastFnName' that doesn't create a qualified name. +toHsConstCastFnName' :: Constness -> Class -> String +toHsConstCastFnName' cst cls = + concat ["cast", toHsDataTypeName' Nonconst cls, + case cst of + Const -> "ToConst" + Nonconst -> "ToNonconst"] + +-- | The name of the data type that represents a pointer to an object of the +-- given class and constness. +toHsDataTypeName :: Constness -> Class -> LH.Generator String +toHsDataTypeName cst cls = + LH.inFunction "toHsDataTypeName" $ + LH.addExtNameModule (classExtName cls) $ toHsDataTypeName' cst cls + +-- | Pure version of 'toHsDataTypeName' that doesn't create a qualified name. +toHsDataTypeName' :: Constness -> Class -> String +toHsDataTypeName' cst cls = LH.toHsTypeName' cst $ classExtName cls + +-- | The name of a data constructor for one of the object pointer types. +toHsDataCtorName :: LH.Managed -> Constness -> Class -> LH.Generator String +toHsDataCtorName m cst cls = + LH.inFunction "toHsDataCtorName" $ + LH.addExtNameModule (classExtName cls) $ toHsDataCtorName' m cst cls + +-- | Pure version of 'toHsDataCtorName' that doesn't create a qualified name. +toHsDataCtorName' :: LH.Managed -> Constness -> Class -> String +toHsDataCtorName' m cst cls = case m of + LH.Unmanaged -> base + LH.Managed -> base ++ "Gc" + where base = toHsDataTypeName' cst cls + +-- | The name of the foreign function import wrapping @delete@ for the given +-- class type. This is in internal to the binding; normal users should use +-- 'Foreign.Hoppy.Runtime.delete'. +-- +-- This is internal to a generated Haskell module, so it does not have a public +-- (qualified) form. +toHsClassDeleteFnName' :: Class -> String +toHsClassDeleteFnName' cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName' Nonconst cls + +-- | The name of the foreign import that imports the same function as +-- 'toHsClassDeleteFnName'', but as a 'Foreign.Ptr.FunPtr' rather than an actual +-- function. +-- +-- This is internal to a generated Haskell module, so it does not have a public +-- (qualified) form. +toHsClassDeleteFnPtrName' :: Class -> String +toHsClassDeleteFnPtrName' cls = + 'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName' Nonconst cls + +-- | Returns the name of the Haskell function that invokes the given +-- constructor. +toHsCtorName :: Class -> Ctor -> LH.Generator String +toHsCtorName cls ctor = + LH.inFunction "toHsCtorName" $ + toHsClassEntityName cls $ fromExtName $ ctorExtName ctor + +-- | Pure version of 'toHsCtorName' that doesn't create a qualified name. +toHsCtorName' :: Class -> Ctor -> String +toHsCtorName' cls ctor = + toHsClassEntityName' cls $ fromExtName $ ctorExtName ctor + +-- | Returns the name of the Haskell function that invokes the given method. +toHsMethodName :: Class -> Method -> LH.Generator String +toHsMethodName cls method = + LH.inFunction "toHsMethodName" $ + toHsClassEntityName cls $ fromExtName $ methodExtName method + +-- | Pure version of 'toHsMethodName' that doesn't create a qualified name. +toHsMethodName' :: Class -> Method -> String +toHsMethodName' cls method = + toHsClassEntityName' cls $ fromExtName $ methodExtName method + +-- | Returns the name of the Haskell function for an entity in a class. +toHsClassEntityName :: IsFnName String name => Class -> name -> LH.Generator String +toHsClassEntityName cls name = + LH.addExtNameModule (classExtName cls) $ toHsClassEntityName' cls name + +-- | Pure version of 'toHsClassEntityName' that doesn't create a qualified name. +toHsClassEntityName' :: IsFnName String name => Class -> name -> String +toHsClassEntityName' cls name = + lowerFirst $ fromExtName $ + classEntityForeignName' cls $ + case toFnName name of + FnName name' -> toExtName name' + FnOp op -> operatorPreferredExtName op + +-- | Generates C++ gateway functions (via 'Function.sayCppExportFn') for getting +-- and setting a variable (possibly a class variable). +sayCppExportVar :: + Type -- ^ The type that the variable holds. + -> Maybe (Type, Type) + -- ^ @Nothing@ if the variable is not a class variable. If it is, then the + -- first type is the generated getter's argument type for the object, and + -- the second is the generated setter's argument type. For a class @cls@, + -- this can be: + -- + -- > Just ('ptrT' $ 'constT' $ 'objT' cls, 'ptrT' $ 'objT' cls) + -> Bool + -- ^ Whether to generate a getter. Passing false here is useful when a + -- variable's type can't be sensibly converted to a foreign language's + -- value. + -> ExtName + -- ^ An external name from which to generate a getter function name. + -> ExtName + -- ^ An external name from which to generate a setter function name. + -> LC.Generator () -- ^ A C++ generator that emits the variable name. + -> LC.Generator () +sayCppExportVar t maybeThisTypes gettable getterName setterName sayVarName = do + let (isConst, deconstType) = case t of + Internal_TConst t' -> (True, t') + t' -> (False, t') + + -- Say a getter function. + when gettable $ + Function.sayCppExportFn getterName + (Function.VarRead sayVarName) + (fmap fst maybeThisTypes) + [] + deconstType + mempty + True + + -- Say a setter function. + unless isConst $ + Function.sayCppExportFn setterName + (Function.VarWrite sayVarName) + (fmap snd maybeThisTypes) + [toParameter $ deconstType] + voidT + mempty + True + +-- | Generates Haskell gateway functions (via 'Function.sayHsExportFn') for +-- getting and setting a variable (possibly a class variable). +sayHsExportVar :: + LH.SayExportMode -- ^ The phase of code generation. + -> Type -- ^ The type that the variable holds. + -> Maybe Class + -- ^ The type of the class holding the variable, if generating code for a + -- class variable. + -> Bool + -- ^ Whether to generate a getter. Passing false here is useful when a + -- variable's type can't be sensibly converted to a foreign language's + -- value. + -> ExtName + -- ^ An external name for the getter. + -> ExtName + -- ^ A foreign external name for the getter. See 'Function.sayHsExportFn'. + -> ExtName + -- ^ An external name for the setter. + -> ExtName + -- ^ A foreign external name for the setter. See 'Function.sayHsExportFn'. + -> LH.Generator () +sayHsExportVar mode + t + classIfNonstatic + gettable + getterExtName + getterForeignName + setterExtName + setterForeignName = do + let (isConst, deconstType) = case t of + Internal_TConst t' -> (True, t') + t' -> (False, t') + + when gettable $ + Function.sayHsExportFn + mode + getterExtName + getterForeignName + Nonpure + (maybe [] (\cls -> [toParameter $ ptrT $ constT $ objT cls]) classIfNonstatic) + deconstType + mempty + + unless isConst $ + Function.sayHsExportFn + mode + setterExtName + setterForeignName + Nonpure + (maybe [toParameter deconstType] + (\cls -> [toParameter $ ptrT $ objT cls, toParameter deconstType]) + classIfNonstatic) + voidT + mempty diff --git a/src/Foreign/Hoppy/Generator/Spec/Class.hs-boot b/src/Foreign/Hoppy/Generator/Spec/Class.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Class.hs-boot @@ -0,0 +1,72 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Spec.Class ( + Class, + classExtName, + classIdentifier, + classReqs, + classConversion, + ClassConversion (..), + ClassHaskellConversion (..), + toHsValueClassName, + toHsWithValuePtrName, + toHsPtrClassName, + toHsCastMethodName, + toHsDataTypeName, + toHsDataCtorName, + ) where + +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Base (Constness, ExtName, Identifier, Reqs) +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import Language.Haskell.Syntax (HsType) + +data Class + +instance Eq Class +instance Ord Class +instance Show Class + +classExtName :: Class -> ExtName + +classIdentifier :: Class -> Identifier + +classReqs :: Class -> Reqs + +classConversion :: Class -> ClassConversion + +data ClassConversion = ClassConversion + { classHaskellConversion :: ClassHaskellConversion + } + +data ClassHaskellConversion = ClassHaskellConversion + { classHaskellConversionType :: Maybe (LH.Generator HsType) + , classHaskellConversionToCppFn :: Maybe (LH.Generator ()) + , classHaskellConversionFromCppFn :: Maybe (LH.Generator ()) + } + +toHsValueClassName :: Class -> LH.Generator String + +toHsWithValuePtrName :: Class -> LH.Generator String + +toHsPtrClassName :: Constness -> Class -> LH.Generator String + +toHsCastMethodName :: Constness -> Class -> LH.Generator String + +toHsDataTypeName :: Constness -> Class -> LH.Generator String + +toHsDataCtorName :: LH.Managed -> Constness -> Class -> LH.Generator String diff --git a/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs --- a/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +++ b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -28,6 +28,7 @@ import Data.Monoid (mempty) #endif import Foreign.Hoppy.Generator.Spec.Base +import Foreign.Hoppy.Generator.Spec.Class import Foreign.Hoppy.Generator.Types -- | Sets of functionality that can be stamped onto a class with diff --git a/src/Foreign/Hoppy/Generator/Spec/Conversion.hs b/src/Foreign/Hoppy/Generator/Spec/Conversion.hs --- a/src/Foreign/Hoppy/Generator/Spec/Conversion.hs +++ b/src/Foreign/Hoppy/Generator/Spec/Conversion.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -17,8 +17,11 @@ {-# LANGUAGE CPP #-} --- | The primary data types for specifying C++ interfaces. +-- | Conversions for C++ classes. -- +-- TODO Refactor this, 'cause the TManual conversion stuff is in Base. (Not a +-- high priority, this /is/ a private module.) +-- -- 'Show' instances in this module produce strings of the form @\"\\"@. They can be used in error messages without -- specifying a noun separately, i.e. write @show cls@ instead of @\"the class @@ -34,10 +37,15 @@ #endif import Foreign.Hoppy.Generator.Language.Haskell import Foreign.Hoppy.Generator.Spec.Base +import Foreign.Hoppy.Generator.Spec.Class import Foreign.Hoppy.Generator.Types -- | Modifies a class's 'ClassConversion' structure by setting all languages --- to use 'ClassConversionToHeap'. +-- to copy objects to the heap when being passed out of C++. Lifetimes of the +-- resulting objects must be managed by code in the foreign language. +-- +-- Calling this on a class makes 'objT' behave like 'objToHeapT' for values +-- being passed out of C++. classSetConversionToHeap :: Class -> Class classSetConversionToHeap cls = case classFindCopyCtor cls of Just _ -> @@ -47,7 +55,12 @@ Nothing -> error $ "classSetConversionToHeap: " ++ show cls ++ " must be copyable." -- | Modifies a class's 'ClassConversion' structure by setting all languages --- that support garbage collection to use 'ClassConversionToGc'. +-- that support garbage collection to copy objects to the heap when being passed +-- out of C++, and put those objects under the care of the foreign language's +-- garbage collector. +-- +-- Calling this on a class makes 'objT' behave like 'toGcT' for values being +-- passed out of C++. classSetConversionToGc :: Class -> Class classSetConversionToGc cls = case classFindCopyCtor cls of Just _ -> diff --git a/src/Foreign/Hoppy/Generator/Spec/Enum.hs b/src/Foreign/Hoppy/Generator/Spec/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Enum.hs @@ -0,0 +1,524 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Interface for defining bindings to C++ enumerations. +-- +-- In generated Haskell code: +-- +-- An enum gets a single algebraic data type with data constructors for each of +-- the values defined in the interface. If the enum has an unknown value name +-- defined, then an additional data constructor is generated that holds a +-- numeric value, and this constructor is used whenever numeric values for which +-- no name is explicitly defined are encountered (otherwise, 'error' is called). +-- +-- From the runtime module, a @CppEnum@ instance is generated for the type, and +-- if the enum is declared to permit bit operations, then a 'Data.Bits.Bits' +-- instance is also generated. 'Eq' and 'Ord' instances are generated that +-- compare numeric values. +module Foreign.Hoppy.Generator.Spec.Enum ( + -- * Data type + CppEnum, enumT, + -- * Construction + makeEnum, makeAutoEnum, IsAutoEnumValue (..), + -- * Properties + enumExtName, + enumIdentifier, + enumNumericType, enumSetNumericType, + enumValues, + enumReqs, + enumAddendum, + enumValuePrefix, enumSetValuePrefix, + enumAddEntryNameOverrides, + enumGetOverriddenEntryName, + IsEnumUnknownValueEntry (..), + enumUnknownValueEntry, enumSetUnknownValueEntry, enumSetNoUnknownValueEntry, + enumUnknownValueEntryDefault, + enumHasBitOperations, enumSetHasBitOperations, + -- * C++ generator + cppGetEvaluatedEnumData, + -- * Haskell generator + hsGetEvaluatedEnumData, + -- ** Names + toHsEnumTypeName, toHsEnumTypeName', + toHsEnumCtorName, toHsEnumCtorName', + ) where + +import Control.Arrow ((&&&), (***)) +import Control.Monad (forM, forM_, when) +import Control.Monad.Except (throwError) +import Data.Function (on) +import qualified Data.Map as M +import Foreign.Hoppy.Generator.Common (butLast, capitalize, for) +import Foreign.Hoppy.Generator.Spec.Base +import qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import Foreign.Hoppy.Generator.Override (addOverrideMap, overriddenMapLookup, plainMap) +import Foreign.Hoppy.Generator.Types (manualT) +import Foreign.Hoppy.Generator.Util (splitIntoWords) +import GHC.Stack (HasCallStack) +import Language.Haskell.Syntax ( + HsName (HsIdent), + HsQName (UnQual), + HsType (HsTyCon), + ) + +-- | A C++ enum declaration. +-- +-- See 'Foreign.Hoppy.Generator.Spec.EnumInfo'. +data CppEnum = CppEnum + { enumExtName :: ExtName + -- ^ The enum's external name. + , enumIdentifier :: Identifier + -- ^ The identifier used to refer to the enum. + , enumNumericType :: Maybe Type + -- ^ An optional, explicit numeric type provided for the enum's values, that + -- matches what the C++ compiler uses. Hoppy will use + -- 'Foreign.Hoppy.Generator.Hook.Hooks' to compute this automatically, if + -- not given manually. This does not need to be provided. If absent + -- (default), then Hoppy will calculate the enum's numeric type on its own, + -- using a C++ compiler. If this is present however, Hoppy will use it, and + -- additionally validate it against what the C++ compiler thinks, if + -- validation is enabled (see 'interfaceValidateEnumTypes'). + , enumValues :: EnumValueMap + -- ^ The numeric values and names of the enum entires. + , enumReqs :: Reqs + -- ^ Requirements for bindings to access this enum. Currently unused, but + -- will be in the future. + , enumAddendum :: Addendum + -- ^ The enum's addendum. + , enumValuePrefix :: String + -- ^ The prefix applied to value names ('enumValues') when determining the + -- names of values in foreign languages. This defaults to the external name + -- of the enum, plus an underscore. + -- + -- See 'enumSetValuePrefix'. + , enumUnknownValueEntry :: Maybe EnumEntryWords + -- ^ A name (a list of words, a la the fields in 'EnumValueMap') for an + -- optional fallback enum "entry" in generated bindings for holding unknown + -- values. See 'enumUnknownValueEntryDefault'. + -- + -- When this is a @Just@, then the generated foreign binding gets an extra + -- entry that takes an argument holding an arbitrary numeric value (an extra + -- data constructor in Haskell), and this value is used whenever an unknown + -- value is seen. + -- + -- When this is @Nothing@, the enum will not support unknown values. + -- @toCppEnum@ in the @Foreign.Hoppy.Runtime.CppEnum@ typeclass, as well as + -- calls or returns from C++ that pass a value not defined in the interface, + -- will raise an 'error'. + -- + -- Enums that have this set to @Nothing@ should also have + -- 'enumHasBitOperations' set to false, to avoid potential errors at + -- runtime; see that function's documentation. + -- + -- The 'enumValuePrefix' applies to this name, just as it does to other enum + -- entries. + , enumHasBitOperations :: Bool + -- ^ Whether generated bindings should support bitwise operations on the + -- enum. This defaults to true. + -- + -- It is not recommended to disable the unknown value entry + -- ('enumUnknownValueEntry') while having this be true, because any + -- computation involving enum values not explicitly defined will cause a + -- runtime error. This includes undefined combinations of defined values. + } + +instance Eq CppEnum where + (==) = (==) `on` enumExtName + +instance Show CppEnum where + show e = concat [""] + +instance Exportable CppEnum where + sayExportCpp _ _ = return () -- Nothing to do for the C++ side of an enum. + + sayExportHaskell = sayHsExport + + getExportEnumInfo e = + Just EnumInfo + { enumInfoExtName = enumExtName e + , enumInfoIdentifier = enumIdentifier e + , enumInfoNumericType = enumNumericType e + , enumInfoReqs = enumReqs e + , enumInfoValues = enumValues e + } + +instance HasExtNames CppEnum where + getPrimaryExtName = enumExtName + +instance HasReqs CppEnum where + getReqs = enumReqs + setReqs reqs e = e { enumReqs = reqs } + +instance HasAddendum CppEnum where + getAddendum = enumAddendum + setAddendum addendum e = e { enumAddendum = addendum } + +-- | Sets an explicit numeric type for the enum. See 'enumNumericType'. +enumSetNumericType :: Maybe Type -> CppEnum -> CppEnum +enumSetNumericType maybeType enum = enum { enumNumericType = maybeType } + +-- | The default value for 'enumUnknownValueEntry'. This is @[\"Unknown\"]@. +enumUnknownValueEntryDefault :: EnumEntryWords +enumUnknownValueEntryDefault = ["Unknown"] + +-- | Creates a binding for a C++ enum. +-- +-- The numeric values of each of the enum's entries must be specified manually +-- using this function. To have these determined automatically, instead use +-- 'makeAutoEnum'. +makeEnum :: + Identifier -- ^ 'enumIdentifier' + -> Maybe ExtName + -- ^ An optional external name; will be automatically derived from + -- the identifier if absent. + -> [(Integer, EnumEntryWords)] + -- ^ A list of (numeric value, symbolic name) pairs describing enum entries to + -- generate bindings for. Each symbolic name is a list of words, which will + -- be combined into a single identifier of appropriate naming style for the + -- target language (title case, for Haskell) with 'enumValuePrefix' prepended. + -> CppEnum +makeEnum identifier maybeExtName entries = + let extName = extNameOrIdentifier identifier maybeExtName + in CppEnum + extName + identifier + Nothing + (let entries' = for entries $ \(num, words') -> (words', EnumValueManual num) + entryNames = map fst entries' + in EnumValueMap + { enumValueMapNames = entryNames + , enumValueMapForeignNames = plainMap $ M.fromList $ map (id &&& id) entryNames + , enumValueMapValues = M.fromList entries' + }) + mempty + mempty + (fromExtName extName ++ "_") + (Just enumUnknownValueEntryDefault) + True + +-- | Creates a binding for a C++ enum. +-- +-- An enum created using this function will determine its entries' numeric +-- values automatically when the generator is run, by compiling a C++ program. +makeAutoEnum :: + IsAutoEnumValue v + => Identifier -- ^ 'enumIdentifier' + -> Maybe ExtName + -- ^ An optional external name; will be automatically derived from the + -- identifier if absent. + -> Bool + -- ^ Is the enum scoped (@enum class@ or @enum struct@)? That is, are its + -- entries scoped underneath its name, rather than being at the same level as + -- its name (as with just @enum@). + -> [v] + -- ^ A list of enum entries to calculate and generate bindings for. See + -- 'IsAutoEnumValue'. + -> CppEnum +makeAutoEnum identifier maybeExtName scoped entries = + let extName = extNameOrIdentifier identifier maybeExtName + in CppEnum + extName + identifier + Nothing + (let namespaceForValues = + if scoped + then identifier + else makeIdentifier $ butLast $ identifierParts identifier + entries' = + map (fmap (\name -> namespaceForValues `mappend` ident name) . + toAutoEnumValue) + entries + entryNames = map fst entries' + in EnumValueMap + { enumValueMapNames = entryNames + , enumValueMapForeignNames = plainMap $ M.fromList $ map (id &&& id) entryNames + , enumValueMapValues = M.map EnumValueAuto $ M.fromList entries' + }) + mempty + mempty + (fromExtName extName ++ "_") + (Just enumUnknownValueEntryDefault) + True + +-- | Represents a mapping to an automatically evaluated C++ enum entry. +-- +-- The @('EnumEntryWords', String)@ instance is the canonical one, with +-- 'toAutoEnumValue' defined as @id@. The string on the right is the C++ name +-- of the entry, and the list of strings on the left are the words from which to +-- generate foreign binding's entries. +-- +-- The @String@ instance takes the C++ name of the entry, and splits it into +-- words via 'splitIntoWords'. +class IsAutoEnumValue a where + toAutoEnumValue :: a -> (EnumEntryWords, String) + +instance IsAutoEnumValue (EnumEntryWords, String) where + toAutoEnumValue = id + +instance IsAutoEnumValue String where + toAutoEnumValue = splitIntoWords &&& id + +-- | Adds overrides for some of an enum's entry names, in a specific language. +enumAddEntryNameOverrides :: IsAutoEnumValue v => ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum +enumAddEntryNameOverrides lang nameOverrides enum = enum { enumValues = enumValues' } + where enumValues' = + (enumValues enum) + { enumValueMapForeignNames = + addOverrideMap lang overrideMap $ enumValueMapForeignNames $ enumValues enum } + overrideMap = M.fromList $ map (toEntryName *** toEntryName) nameOverrides + toEntryName = fst . toAutoEnumValue + +-- | Retrieves the name for an enum entry in a specific foreign language. +enumGetOverriddenEntryName :: ForeignLanguage -> CppEnum -> EnumEntryWords -> EnumEntryWords +enumGetOverriddenEntryName lang enum words' = + case overriddenMapLookup lang words' $ enumValueMapForeignNames $ enumValues enum of + Just words'' -> words'' + Nothing -> + error $ "enumGetOverriddenEntryName: Entry with name " ++ show words' ++ + " not found in " ++ show enum ++ "." + +-- | Sets the prefix applied to the names of enum values' identifiers in foreign +-- languages. +-- +-- See 'enumValuePrefix'. +enumSetValuePrefix :: String -> CppEnum -> CppEnum +enumSetValuePrefix prefix enum = enum { enumValuePrefix = prefix } + +-- | Sets the entry name (a list of words, a la the fields in 'EnumValueMap') +-- for the fallback enum entry that holds unknown values. +-- +-- Set 'enumUnknownValueEntry', 'enumSetNoUnknownValueEntry'. +enumSetUnknownValueEntry :: IsEnumUnknownValueEntry a => a -> CppEnum -> CppEnum +enumSetUnknownValueEntry name enum = + enum { enumUnknownValueEntry = Just $ toEnumUnknownValueEntry name } + +-- | Sets an enum to have no unknown value entry. +-- +-- Set 'enumUnknownValueEntry', 'enumSetUnknownValueEntry'. +enumSetNoUnknownValueEntry :: CppEnum -> CppEnum +enumSetNoUnknownValueEntry enum = + enum { enumUnknownValueEntry = Nothing } + +-- | Values that can be used as a name for an enum's unknown value entry. See +-- 'enumUnknownValueEntry'. +class IsEnumUnknownValueEntry a where + -- | Converts a value to a list of words to use for an enum's unknown entry + -- name. + toEnumUnknownValueEntry :: a -> EnumEntryWords + +instance IsEnumUnknownValueEntry EnumEntryWords where + toEnumUnknownValueEntry = id + +instance IsEnumUnknownValueEntry String where + toEnumUnknownValueEntry = splitIntoWords + +-- | Sets whether generated bindings will support bitwise operations on the +-- enum. +-- +-- See 'enumHasBitOperations'. +enumSetHasBitOperations :: Bool -> CppEnum -> CppEnum +enumSetHasBitOperations b enum = enum { enumHasBitOperations = b } + +makeConversion :: CppEnum -> ConversionSpec +makeConversion e = + (makeConversionSpec (show e) cpp) + { conversionSpecHaskell = Just hs } + where cpp = + makeConversionSpecCpp (LC.renderIdentifier $ enumIdentifier e) + (return $ enumReqs e) + + hs = + makeConversionSpecHaskell + (HsTyCon . UnQual . HsIdent <$> toHsEnumTypeName e) + (Just $ do evaluatedData <- hsGetEvaluatedEnumData $ enumExtName e + LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData) + (CustomConversion $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude, + hsImportForRuntime] + LH.sayLn "HoppyP.return . HoppyFHR.fromCppEnum") + (CustomConversion $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude, + hsImportForRuntime] + LH.sayLn "HoppyP.return . HoppyFHR.toCppEnum") + +-- | Constructs a type value for an enum. +enumT :: CppEnum -> Type +-- (Keep docs in sync with hs-boot.) +enumT = manualT . makeConversion + +sayHsExport :: LH.SayExportMode -> CppEnum -> LH.Generator () +sayHsExport mode enum = + LH.withErrorContext ("generating enum " ++ show (enumExtName enum)) $ + case mode of + -- Nothing to import from the C++ side of an enum. + LH.SayExportForeignImports -> return () + + LH.SayExportDecls -> do + hsTypeName <- toHsEnumTypeName enum + evaluatedData <- hsGetEvaluatedEnumData $ enumExtName enum + numericType <- LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData + let evaluatedValueMap = evaluatedEnumValueMap evaluatedData + evaluatedValues <- forM (enumValueMapNames $ enumValues enum) $ \name -> + case M.lookup name evaluatedValueMap of + Just value -> return (name, value) + Nothing -> throwError $ "Couldn't find evaluated value for " ++ show name + values :: [(Integer, String)] <- forM evaluatedValues $ \(entryName, value) -> do + let entryName' = enumGetOverriddenEntryName Haskell enum entryName + ctorName <- toHsEnumCtorName enum entryName' + return (value, ctorName) + maybeUnknownValueCtorName <- forM (enumUnknownValueEntry enum) $ toHsEnumCtorName enum + LH.addImports $ mconcat [hsImport1 "Prelude" "(==)", + hsImportForPrelude, + hsImportForRuntime] + + -- Print out the data declaration. + LH.ln + LH.addExport' hsTypeName + LH.saysLn ["data ", hsTypeName, " ="] + LH.indent $ do + forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) -> + LH.saysLn [if cont then "| " else "", hsCtorName] + -- Only print an unknown value ctor if one has been requested. + forM_ maybeUnknownValueCtorName $ \unknownValueCtorName -> + LH.saysLn ["| ", unknownValueCtorName, " (", LH.prettyPrint numericType, ")"] + LH.sayLn "deriving (HoppyP.Show)" + + -- Print out the (runtime) CppEnum instance. + LH.ln + LH.saysLn ["instance HoppyFHR.CppEnum (", LH.prettyPrint numericType, ") ", hsTypeName, + " where"] + LH.indent $ do + forM_ values $ \(num, hsCtorName) -> + LH.saysLn ["fromCppEnum ", hsCtorName, " = ", show num] + forM_ maybeUnknownValueCtorName $ \unknownValueCtorName -> + LH.saysLn ["fromCppEnum (", unknownValueCtorName, " n) = n"] + LH.ln + -- We pass the values list through a map here to only keep the first + -- constructor mapped to each numeric value, otherwise we'd write + -- duplicate cases. + forM_ (M.toList $ M.fromListWith const values) $ \(num, hsCtorName) -> + LH.saysLn ["toCppEnum (", show num, ") = ", hsCtorName] + case maybeUnknownValueCtorName of + Just unknownValueCtorName -> LH.saysLn ["toCppEnum n = ", unknownValueCtorName, " n"] + Nothing -> do + LH.addImports $ hsImports "Prelude" ["($)", "(++)"] + LH.saysLn ["toCppEnum n' = HoppyP.error $ ", + show (concat ["Unknown ", hsTypeName, " numeric value: "]), + " ++ HoppyP.show n'"] + + -- Print out Eq and Ord instances. + LH.ln + LH.saysLn ["instance HoppyP.Eq ", hsTypeName, " where"] + LH.indent $ + LH.sayLn "x == y = HoppyFHR.fromCppEnum x == HoppyFHR.fromCppEnum y" + LH.ln + LH.saysLn ["instance HoppyP.Ord ", hsTypeName, " where"] + LH.indent $ + LH.sayLn "compare x y = HoppyP.compare (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)" + + when (enumHasBitOperations enum) $ do + LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"], + hsImports "Data.Bits" ["(.&.)", "(.|.)"], + hsImportForBits] + LH.saysLn ["instance HoppyDB.Bits ", hsTypeName, " where"] + LH.indent $ do + let fun1 f = + LH.saysLn [f, " x = HoppyFHR.toCppEnum $ HoppyDB.", + f, " $ HoppyFHR.fromCppEnum x"] + fun1Int f = + LH.saysLn [f, " x i = HoppyFHR.toCppEnum $ HoppyDB.", + f, " (HoppyFHR.fromCppEnum x) i"] + fun2 f = + LH.saysLn [f, " x y = HoppyFHR.toCppEnum $ HoppyDB.", + f, " (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)"] + op2 op = + LH.saysLn ["x ", op, " y = HoppyFHR.toCppEnum ", + "(HoppyFHR.fromCppEnum x ", op, " HoppyFHR.fromCppEnum y)"] + op2 ".&." + op2 ".|." + fun2 "xor" + fun1 "complement" + fun1Int "shift" + fun1Int "rotate" + LH.sayLn "bitSize x = case HoppyDB.bitSizeMaybe x of" + LH.indent $ do + LH.sayLn " HoppyP.Just n -> n" + -- Same error message as the prelude here: + LH.sayLn " HoppyP.Nothing -> HoppyP.error \"bitSize is undefined\"" + LH.sayLn "bitSizeMaybe = HoppyDB.bitSizeMaybe . HoppyFHR.fromCppEnum" + LH.sayLn "isSigned = HoppyDB.isSigned . HoppyFHR.fromCppEnum" + LH.sayLn "testBit x i = HoppyDB.testBit (HoppyFHR.fromCppEnum x) i" + LH.sayLn "bit = HoppyFHR.toCppEnum . HoppyDB.bit" + LH.sayLn "popCount = HoppyDB.popCount . HoppyFHR.fromCppEnum" + + LH.SayExportBoot -> do + hsTypeName <- toHsEnumTypeName enum + evaluatedData <- hsGetEvaluatedEnumData $ enumExtName enum + numericType <- LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData + LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + LH.addExport hsTypeName + LH.ln + LH.saysLn ["data ", hsTypeName] + LH.saysLn ["instance HoppyFHR.CppEnum (", LH.prettyPrint numericType, ") ", hsTypeName] + LH.saysLn ["instance HoppyP.Eq ", hsTypeName] + LH.saysLn ["instance HoppyP.Ord ", hsTypeName] + LH.saysLn ["instance HoppyP.Show ", hsTypeName] + when (enumHasBitOperations enum) $ do + LH.addImports hsImportForBits + LH.saysLn ["instance HoppyDB.Bits ", hsTypeName] + +-- | Reads evaluated data for the named enum from the C++ generator environment. +cppGetEvaluatedEnumData :: HasCallStack => ExtName -> LC.Generator EvaluatedEnumData +cppGetEvaluatedEnumData extName = do + iface <- LC.askInterface + return $ interfaceGetEvaluatedEnumData iface extName + +-- | Reads evaluated data for the named enum from the Haskell generator +-- environment. +hsGetEvaluatedEnumData :: HasCallStack => ExtName -> LH.Generator EvaluatedEnumData +hsGetEvaluatedEnumData extName = do + iface <- LH.askInterface + return $ interfaceGetEvaluatedEnumData iface extName + +-- | Returns the Haskell name for an enum. +-- +-- TODO Clarify, and split into type and data ctor names. +toHsEnumTypeName :: CppEnum -> LH.Generator String +toHsEnumTypeName enum = + LH.inFunction "toHsEnumTypeName" $ + LH.addExtNameModule (enumExtName enum) $ toHsEnumTypeName' enum + +-- | Pure version of 'toHsEnumTypeName' that doesn't create a qualified name. +toHsEnumTypeName' :: CppEnum -> String +toHsEnumTypeName' = LH.toHsTypeName' Nonconst . enumExtName + +-- | Constructs the data constructor name for a value in an enum. Like C++ and +-- unlike say Java, Haskell enum values aren't in a separate enum-specific +-- namespace, so we prepend the enum name to the value name to get the data +-- constructor name. The value name is a list of words. +toHsEnumCtorName :: CppEnum -> EnumEntryWords -> LH.Generator String +toHsEnumCtorName enum words' = + LH.inFunction "toHsEnumCtorName" $ + LH.addExtNameModule (enumExtName enum) $ toHsEnumCtorName' enum words' + +-- | Pure version of 'toHsEnumCtorName' that doesn't create a qualified name. +toHsEnumCtorName' :: CppEnum -> EnumEntryWords -> String +toHsEnumCtorName' enum words' = + concat $ enumValuePrefix enum : map capitalize words' diff --git a/src/Foreign/Hoppy/Generator/Spec/Enum.hs-boot b/src/Foreign/Hoppy/Generator/Spec/Enum.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Enum.hs-boot @@ -0,0 +1,27 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Spec.Enum ( + enumT, + ) where + +import Foreign.Hoppy.Generator.Spec.Base (Type) + +data CppEnum + +-- | Constructs a type value for an enum. +enumT :: CppEnum -> Type diff --git a/src/Foreign/Hoppy/Generator/Spec/Function.hs b/src/Foreign/Hoppy/Generator/Spec/Function.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Function.hs @@ -0,0 +1,905 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +{-# LANGUAGE ViewPatterns #-} + +-- | Interface for defining bindings to C++ functions. +module Foreign.Hoppy.Generator.Spec.Function ( + -- * Data type + Function, fnT, fnT', + -- * Construction + makeFn, + -- * Properties + fnExtName, + fnCName, + fnPurity, + fnParams, + fnReturn, + fnReqs, + fnAddendum, + fnExceptionHandlers, + -- * Code generators + CallDirection (..), + -- ** C++ generator + CppCallType (..), + sayCppArgRead, + sayCppArgNames, + -- * Internal + -- ** C++ generator + sayCppExportFn, + -- ** Haskell generator + sayHsExportFn, + sayHsArgProcessing, + sayHsCallAndProcessReturn, + ) where + +import Control.Monad (forM_, unless, when) +import Control.Monad.Except (throwError) +import Data.Function (on) +import Data.List (intersperse) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Foreign.Hoppy.Generator.Common (fromMaybeM) +import qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Spec.Class as Class +import Foreign.Hoppy.Generator.Spec.Base +import Foreign.Hoppy.Generator.Types (constT, intT, objT, objToHeapT, ptrT, refT, voidT) +import Language.Haskell.Syntax ( + HsContext, + HsName (HsIdent), + HsQName (UnQual), + HsQualType (HsQualType), + HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar), + ) + +-- | A C++ function declaration. +-- +-- Use this data type's 'HasReqs' instance to make the function accessible. You +-- do not need to add requirements for parameter or return types. +data Function = Function + { fnCName :: FnName Identifier + -- ^ The identifier used to call the function. + , fnExtName :: ExtName + -- ^ The function's external name. + , fnPurity :: Purity + -- ^ Whether the function is pure. + , fnParams :: [Parameter] + -- ^ The function's parameters. + , fnReturn :: Type + -- ^ The function's return type. + , fnReqs :: Reqs + -- ^ Requirements for bindings to access this function. + , fnExceptionHandlers :: ExceptionHandlers + -- ^ Exceptions that the function might throw. + , fnAddendum :: Addendum + -- ^ The function's addendum. + } + +instance Eq Function where + (==) = (==) `on` fnExtName + +instance Show Function where + show fn = + concat [""] + +instance Exportable Function where + sayExportCpp = sayCppExport + sayExportHaskell = sayHsExport + +instance HasExtNames Function where + getPrimaryExtName = fnExtName + +instance HasReqs Function where + getReqs = fnReqs + setReqs reqs fn = fn { fnReqs = reqs } + +instance HasAddendum Function where + getAddendum = fnAddendum + setAddendum addendum fn = fn { fnAddendum = addendum } + +instance HandlesExceptions Function where + getExceptionHandlers = fnExceptionHandlers + modifyExceptionHandlers f fn = fn { fnExceptionHandlers = f $ fnExceptionHandlers fn } + +-- | Creates a binding for a C++ function. +makeFn :: (IsFnName Identifier name, IsParameter p) + => name + -> Maybe ExtName + -- ^ An optional external name; will be automatically derived from + -- the identifier if absent. + -> Purity + -> [p] -- ^ Parameter types. + -> Type -- ^ Return type. + -> Function +makeFn cName maybeExtName purity paramTypes retType = + let fnName = toFnName cName + in Function fnName + (extNameOrFnIdentifier fnName maybeExtName) + purity (toParameters paramTypes) retType mempty mempty mempty + +-- | A function taking parameters and returning a value (or 'voidT'). Function +-- pointers must wrap a 'fnT' in a 'ptrT'. +-- +-- See also 'fnT'' which accepts parameter information. +fnT :: [Type] -> Type -> Type +-- (Keep docs in sync with hs-boot.) +fnT = Internal_TFn . map toParameter + +-- | A version of 'fnT' that accepts additional information about parameters. +fnT' :: [Parameter] -> Type -> Type +-- (Keep docs in sync with hs-boot.) +fnT' = Internal_TFn + +sayCppExport :: LC.SayExportMode -> Function -> LC.Generator () +sayCppExport mode fn = case mode of + LC.SayHeader -> return () + LC.SaySource -> do + LC.addReqsM $ fnReqs fn + sayCppExportFn (fnExtName fn) + (case fnCName fn of + FnName identifier -> CallFn $ LC.sayIdentifier identifier + FnOp op -> CallOp op) + Nothing + (fnParams fn) + (fnReturn fn) + (fnExceptionHandlers fn) + True -- Render the body. + +-- | The direction between languages in which a value is being passed. +data CallDirection = + ToCpp -- ^ Haskell code is calling out to C++. + | FromCpp -- ^ C++ is invoking a callback. + deriving (Show) + +-- | The name of a function to call. +data CppCallType = + CallOp Operator + -- ^ A call to the given operator, for example @x++@, @x * y@, @a[i]@. + | CallFn (LC.Generator ()) + -- ^ A call to the function whose name is emitted by the given action. + | VarRead (LC.Generator ()) + -- ^ Not a function call, but a read from a variable whose name is emitted + -- by the given action. + | VarWrite (LC.Generator ()) + -- ^ Not a function call, but a write to a variable whose name is emitted by + -- the given action. + +-- | Generates a C++ wrapper function for calling a C++ function (or method, or +-- reading from or writing to a variable). The generated function handles +-- C++-side marshalling of values and propagating exceptions as requested. +-- +-- See also 'sayHsExportFn'. +sayCppExportFn :: + ExtName -- ^ The external name of the function. + -> CppCallType -- ^ The C++ name at which the function can be invoked. + -> Maybe Type + -- ^ If present, then we are wrapping a method within some class, and the + -- type is that of the class. + -> [Parameter] -- ^ Info about the function's parameters. + -> Type -- ^ The function's return type. + -> ExceptionHandlers + -- ^ Exception handlers configured on the function itself. No need to call + -- 'LC.getEffectiveExceptionHandlers' to combine the function's handlers + -- with those from the module and interface; this function does that already. + -> Bool + -- ^ Whether to generate the function definition. If false, only the + -- declaration is generated (no function body). + -> LC.Generator () +sayCppExportFn extName callType maybeThisType params retType exceptionHandlers sayBody = do + handlerList <- exceptionHandlersList <$> LC.getEffectiveExceptionHandlers exceptionHandlers + let paramTypes = map parameterType params + catches = not $ null handlerList + addExceptionParamNames = + if catches then (++ [LC.exceptionIdArgName, LC.exceptionPtrArgName]) else id + addExceptionParamTypes = if catches then (++ [ptrT intT, ptrT $ ptrT voidT]) else id + + paramCount = length paramTypes + paramCTypeMaybes <- mapM LC.typeToCType paramTypes + let paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes + retCTypeMaybe <- LC.typeToCType retType + let retCType = fromMaybe retType retCTypeMaybe + + LC.addReqsM . mconcat =<< mapM LC.typeReqs (retType:paramTypes) + + LC.sayFunction (LC.externalNameToCpp extName) + (maybe id (const ("self":)) maybeThisType $ + addExceptionParamNames $ + zipWith3 (\pt ctm -> + -- TManual needs special handling to determine whether a + -- conversion is necessary. 'typeToCType' doesn't suffice + -- because for TManual this check relies on the direction of + -- the call. See the special case in 'sayCppArgRead' as + -- well. + let hasConversion = case pt of + Internal_TManual s -> + isJust $ conversionSpecCppConversionToCppExpr $ + conversionSpecCpp s + _ -> isJust ctm + in if hasConversion then LC.toArgNameAlt else LC.toArgName) + paramTypes + paramCTypeMaybes + [1..paramCount]) + (fnT (addExceptionParamTypes $ maybe id (:) maybeThisType paramCTypes) + retCType) $ + if not sayBody + then Nothing + else Just $ do + when catches $ do + LC.say "try {\n" + LC.says ["*", LC.exceptionIdArgName, " = 0;\n"] + + -- Convert arguments that aren't passed in directly. + mapM_ (sayCppArgRead ToCpp) $ zip3 [1..] paramTypes paramCTypeMaybes + + let -- Determines how to call the exported function or method. + sayCall = case callType of + CallOp op -> do + LC.say "(" + let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0 + paramNames@(p1:p2:_) = (if isJust maybeThisType then ("(*self)":) else id) $ + map LC.toArgName [1..] + assertParamCount n = + when (effectiveParamCount /= n) $ LC.abort $ concat + ["sayCppExportFn: Operator ", show op, " for export ", show extName, + " requires ", show n, " parameter(s), but has ", show effectiveParamCount, + "."] + case operatorType op of + UnaryPrefixOperator symbol -> assertParamCount 1 >> LC.says [symbol, p1] + UnaryPostfixOperator symbol -> assertParamCount 1 >> LC.says [p1, symbol] + BinaryOperator symbol -> assertParamCount 2 >> LC.says [p1, symbol, p2] + CallOperator -> + LC.says $ p1 : "(" : take (effectiveParamCount - 1) (drop 1 paramNames) ++ [")"] + ArrayOperator -> assertParamCount 2 >> LC.says [p1, "[", p2, "]"] + LC.say ")" + CallFn sayCppName -> do + when (isJust maybeThisType) $ LC.say "self->" + sayCppName + LC.say "(" + sayCppArgNames paramCount + LC.say ")" + VarRead sayVarName -> do + when (isJust maybeThisType) $ LC.say "self->" + sayVarName + VarWrite sayVarName -> do + when (isJust maybeThisType) $ LC.say "self->" + sayVarName + LC.says [" = ", LC.toArgName 1] + + -- Writes the call, transforming the return value if necessary. + -- These translations should be kept in sync with typeToCType. + sayCallAndReturn retType' retCTypeMaybe' = case (retType', retCTypeMaybe') of + -- Void needs special handling because we don't want a return statement. + (Internal_TVoid, Nothing) -> sayCall >> LC.say ";\n" + + -- Custom conversions. + (Internal_TManual s, _) -> do + -- The ConversionSpec s may or may not specify an intermediate + -- type to pass over the FFI boundary: the second value in the + -- pair (we check this before the (_, Nothing) case below). We + -- don't actually care what it is though, because s already + -- specifies how to convert. + case conversionSpecCppConversionToCppExpr $ conversionSpecCpp s of + -- If there is a custom conversion expression defined, use it. + Just convFn -> LC.say "return " >> convFn sayCall Nothing >> LC.say ";\n" + -- Otherwise, assume we can just return the value directly. + Nothing -> sayCallAndReturnDirect + + -- The case of a value for which no conversion is necessary. + (_, Nothing) -> sayCallAndReturnDirect + + -- Object cases. + (Internal_TRef cls, Just (Internal_TPtr cls')) | cls == cls' -> + LC.say "return &(" >> sayCall >> LC.say ");\n" + (Internal_TObj cls, + Just (Internal_TPtr (Internal_TConst (Internal_TObj cls')))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TObjToHeap cls, Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TToGc (Internal_TObj cls), + Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TToGc retType'', _) -> sayCallAndReturn retType'' retCTypeMaybe' + + ts -> LC.abort $ concat ["sayCppExportFn: Unexpected return types ", show ts, + " while generating binding for ", show extName, "."] + + sayCallAndReturnDirect = LC.say "return " >> sayCall >> LC.say ";\n" + + sayCallAndReturn retType retCTypeMaybe + + when catches $ do + iface <- LC.askInterface + + forM_ handlerList $ \handler -> do + LC.say "} catch (" + case handler of + CatchClass cls -> LC.sayVar LC.exceptionVarName Nothing $ refT $ constT $ objT cls + CatchAll -> LC.say "..." + LC.say ") {\n" + + exceptionId <- case handler of + CatchClass cls -> case interfaceExceptionClassId iface cls of + Just exceptionId -> return exceptionId + Nothing -> LC.abort $ concat + ["sayCppExportFn: Trying to catch non-exception class ", show cls, + " while generating binding for ", show extName, "."] + CatchAll -> return exceptionCatchAllId + LC.says ["*", LC.exceptionIdArgName, " = ", show $ getExceptionId exceptionId, ";\n"] + + case handler of + CatchAll -> LC.says ["*", LC.exceptionPtrArgName, " = 0;\n"] + CatchClass cls -> do + -- Object pointers don't convert automatically to void*. + LC.says ["*", LC.exceptionPtrArgName, " = reinterpret_cast(new "] + LC.sayType Nothing $ objT cls + LC.says ["(", LC.exceptionVarName, "));\n"] + + -- For all of the types our gateway functions actually return, "return + -- 0" is a valid statement. + when (retType /= Internal_TVoid) $ LC.say "return 0;\n" + + LC.say "}\n" + + where sayReturnNew cls sayCall = + LC.say "return new" >> LC.sayIdentifier (Class.classIdentifier cls) >> LC.say "(" >> + sayCall >> LC.say ");\n" + +-- | Generates code to marshal a value between a C++ type and the intermediate +-- type to be used over the FFI. If @dir@ is 'ToCpp', then we are a C++ +-- function reading an argument from foreign code. If @dir@ is 'FromCpp', then +-- we are invoking a foreign callback. +sayCppArgRead :: CallDirection -> (Int, Type, Maybe Type) -> LC.Generator () +sayCppArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of + t@(Internal_TPtr (Internal_TFn params retType)) -> do + -- Assert that all types referred to in a function pointer type are all + -- representable as C types. + let paramTypes = map parameterType params + check label t' = ((label ++ " " ++ show t') <$) <$> LC.typeToCType t' + mismatches <- + fmap catMaybes $ + (:) <$> check "return type" retType + <*> mapM (\paramType -> check "parameter" paramType) paramTypes + unless (null mismatches) $ + LC.abort $ concat $ + "sayCppArgRead: Some types within a function pointer type use non-C types, " : + "but only C types may be used. The unsupported types are: " : + intersperse "; " mismatches ++ [". The whole function type is ", show t, "."] + + convertDefault + + Internal_TRef t -> convertObj t + + Internal_TObj _ -> convertObj $ constT cppType + + Internal_TObjToHeap cls -> case dir of + ToCpp -> error $ objToHeapTWrongDirectionErrorMsg (Just "sayCppArgRead") cls + FromCpp -> do + LC.sayIdentifier $ Class.classIdentifier cls + LC.says ["* ", LC.toArgName n, " = new "] + LC.sayIdentifier $ Class.classIdentifier cls + LC.says ["(", LC.toArgNameAlt n, ");\n"] + + Internal_TToGc t' -> case dir of + ToCpp -> error $ toGcTWrongDirectionErrorMsg (Just "sayCppArgRead") t' + FromCpp -> do + let newCppType = case t' of + -- In the case of (TToGc (TObj _)), we copy the temporary object to + -- the heap and let the foreign language manage that value. + Internal_TObj cls -> objToHeapT cls + _ -> t' + cType <- LC.typeToCType newCppType + sayCppArgRead dir (n, newCppType, cType) + + -- In case of a manual type, apply the custom conversion, if there is one. + Internal_TManual s -> do + let maybeConvExpr = + (case dir of + ToCpp -> conversionSpecCppConversionToCppExpr + FromCpp -> conversionSpecCppConversionFromCppExpr) $ + conversionSpecCpp s + forM_ maybeConvExpr $ \gen -> + gen (LC.say $ LC.toArgNameAlt n) (Just $ LC.say $ LC.toArgName n) + + _ -> convertDefault + + where -- Primitive types don't need to be encoded/decoded. But if maybeCType is a + -- Just, then we're expected to do some encoding/decoding, so something is + -- wrong. + -- + -- TODO Do we need to handle TConst? + convertDefault = forM_ maybeCType $ \cType -> + LC.abort $ concat + ["sayCppArgRead: Don't know how to convert ", show dir, " between C-type ", show cType, + " and C++-type ", show cppType, "."] + + convertObj cppType' = case dir of + ToCpp -> do + LC.sayVar (LC.toArgName n) Nothing $ refT cppType' + LC.says [" = *", LC.toArgNameAlt n, ";\n"] + FromCpp -> do + LC.sayVar (LC.toArgName n) Nothing $ ptrT cppType' + LC.says [" = &", LC.toArgNameAlt n, ";\n"] + +-- | Prints a comma-separated list of the argument names used for C++ gateway +-- functions. The number specifies how many names to print. +sayCppArgNames :: Int -> LC.Generator () +sayCppArgNames count = + LC.says $ intersperse ", " $ map LC.toArgName [1..count] + +sayHsExport :: LH.SayExportMode -> Function -> LH.Generator () +sayHsExport mode fn = + (sayHsExportFn mode <$> fnExtName <*> fnExtName <*> fnPurity <*> + fnParams <*> fnReturn <*> fnExceptionHandlers) fn + +-- | Generates a Haskell wrapper function for calling a C++ function (or method, +-- or reading from or writing to a variable, as with 'sayCppExportFn'). The +-- generated function handles Haskell-side marshalling of values and propagating +-- exceptions as requested. +sayHsExportFn :: + LH.SayExportMode -- ^ The phase of code generation. + -> ExtName + -- ^ The external name for the entity we're generating. For class + -- entities, this will include the class's external name as a prefix. + -> ExtName + -- ^ An alternate external name to use to generate Haskell function names. + -- For non-class entities, this can be just the regular external name. For + -- class entities, in order to strip off the class name that was added so + -- that the entity's external name is unique, this can just be the name of + -- the function, variable, etc. + -> Purity -- ^ Whether or not the function is pure (free of side effects). + -> [Parameter] -- ^ Parameter info. + -> Type -- ^ The return type. + -> ExceptionHandlers + -- ^ Any exception handlers to apply to the binding, in addition to what + -- its module and interface provide. + -> LH.Generator () +sayHsExportFn mode extName foreignName purity params retType exceptionHandlers = do + effectiveHandlers <- LH.getEffectiveExceptionHandlers exceptionHandlers + let handlerList = exceptionHandlersList effectiveHandlers + catches = not $ null handlerList + + paramTypes = map parameterType params + + -- We use the pure version of toHsFnName here; because foreignName isn't an + -- ExtName present in the interface's lookup table, toHsFnName would bail on + -- it. Since functions don't reference each other (e.g. we don't put anything + -- in .hs-boot files for them in circular modules cases), this isn't a problem. + let hsFnName = LH.toHsFnName' foreignName + hsFnImportedName = hsFnName ++ "'" + + case mode of + LH.SayExportForeignImports -> + LH.withErrorContext ("generating imports for function " ++ show extName) $ do + -- Print a "foreign import" statement. + hsCType <- fnToHsTypeAndUse LH.HsCSide purity params retType effectiveHandlers + LH.saysLn ["foreign import ccall \"", LC.externalNameToCpp extName, "\" ", hsFnImportedName, + " :: ", renderFnHsType hsCType] + + LH.SayExportDecls -> LH.withErrorContext ("generating function " ++ show extName) $ do + -- Print the type signature. + LH.ln + LH.addExport hsFnName + hsHsType <- fnToHsTypeAndUse LH.HsHsSide purity params retType effectiveHandlers + LH.saysLn [hsFnName, " :: ", renderFnHsTypeWithNames hsHsType] + + case purity of + Nonpure -> return () + Pure -> LH.saysLn ["{-# NOINLINE ", hsFnName, " #-}"] + + -- Print the function body. + let argNames = map LH.toArgName [1..length paramTypes] + convertedArgNames = map (++ "'") argNames + -- Operators on this line must bind more weakly than operators used below, + -- namely ($) and (>>=). (So finish the line with ($).) + lineEnd <- case purity of + Nonpure -> return [" ="] + Pure -> do LH.addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO] + return [" = HoppySIU.unsafePerformIO $"] + LH.saysLn $ hsFnName : map (' ':) argNames ++ lineEnd + LH.indent $ do + forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') -> + sayHsArgProcessing ToCpp t argName argName' + + exceptionHandling <- + if catches + then do iface <- LH.askInterface + currentModule <- LH.askModule + let exceptionSupportModule = interfaceExceptionSupportModule iface + when (exceptionSupportModule /= Just currentModule) $ + LH.addImports . hsWholeModuleImport . LH.getModuleName iface =<< + fromMaybeM (throwError + "Internal error, an exception support module is not available") + exceptionSupportModule + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime] + return "HoppyFHR.internalHandleExceptions exceptionDb' $" + else return "" + + let callWords = exceptionHandling : hsFnImportedName : map (' ':) convertedArgNames + sayHsCallAndProcessReturn ToCpp retType callWords + + LH.SayExportBoot -> + -- Functions (methods included) cannot be referenced from other exports, + -- so we don't need to emit anything. + -- + -- If this changes, revisit the comment on hsFnName above. + return () + +-- | Generates Haskell code to perform marshalling of a function's argument in a +-- specified direction. +-- +-- This function either generates a line or lines such that subsequent lines can +-- refer to the output binding. The final line is either terminated with +-- +-- > ... $ \value -> +-- +-- or +-- +-- > let ... in +-- +-- so that precedence is not an issue. +sayHsArgProcessing :: + CallDirection -- ^ The direction of the FFI call. + -> Type -- ^ The type of the value to be marshalled. + -> String -- ^ The name of the binding holding the input value. + -> String -- ^ The name of the binding to create for the output value. + -> LH.Generator () +sayHsArgProcessing dir t fromVar toVar = + LH.withErrorContext ("processing argument of type " ++ show t) $ + case t of + Internal_TVoid -> throwError $ "TVoid is not a valid argument type" + -- References and pointers are handled equivalently. + Internal_TPtr (Internal_TObj cls) -> case dir of + ToCpp -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForRuntime] + castMethodName <- Class.toHsCastMethodName Nonconst cls + LH.saysLn ["HoppyFHR.withCppPtr (", castMethodName, " ", fromVar, + ") $ \\", toVar, " ->"] + FromCpp -> do + ctorName <- Class.toHsDataCtorName LH.Unmanaged Nonconst cls + LH.saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"] + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of + ToCpp -> do + -- Same as the (TObj _), ToCpp case. + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForPrelude, + hsImportForRuntime] + withValuePtrName <- Class.toHsWithValuePtrName cls + LH.saysLn [withValuePtrName, " ", fromVar, + " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] + FromCpp -> do + ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls + LH.saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"] + Internal_TPtr _ -> noConversion + Internal_TRef t' -> sayHsArgProcessing dir (ptrT t') fromVar toVar + Internal_TFn {} -> throwError "TFn unimplemented" + Internal_TObj cls -> case dir of + ToCpp -> do + -- Same as the (TPtr (TConst (TObj _))), ToPtr case. + LH.addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForPrelude, + hsImportForRuntime] + withValuePtrName <- Class.toHsWithValuePtrName cls + LH.saysLn [withValuePtrName, " ", fromVar, + " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] + FromCpp -> case Class.classHaskellConversionFromCppFn $ LH.getClassHaskellConversion cls of + Just _ -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "(>>=)", + hsImportForRuntime] + ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls + LH.saysLn ["HoppyFHR.decode (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"] + Nothing -> + throwError $ concat + ["Can't pass a TObj of ", show cls, + " from C++ to Haskell because no class decode conversion is defined"] + Internal_TObjToHeap cls -> case dir of + ToCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls + FromCpp -> sayHsArgProcessing dir (ptrT $ objT cls) fromVar toVar + Internal_TToGc t' -> case dir of + ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' + FromCpp -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "(>>=)", + hsImportForRuntime] + ctorName <- + maybe (throwError $ tToGcInvalidFormErrorMessage Nothing t') + (Class.toHsDataCtorName LH.Unmanaged Nonconst) $ + case stripConst t' of + Internal_TObj cls -> Just cls + Internal_TRef (Internal_TConst (Internal_TObj cls)) -> Just cls + Internal_TRef (Internal_TObj cls) -> Just cls + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> Just cls + Internal_TPtr (Internal_TObj cls) -> Just cls + _ -> Nothing + LH.saysLn ["HoppyFHR.toGc (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"] + Internal_TConst t' -> sayHsArgProcessing dir t' fromVar toVar + + Internal_TManual s -> do + let maybeGen = + fmap (case dir of + ToCpp -> conversionSpecHaskellToCppFn + FromCpp -> conversionSpecHaskellFromCppFn) $ + conversionSpecHaskell s + throwForNoConversion = + throwError $ concat + ["No conversion defined for ", show s, + case dir of + ToCpp -> " to C++ from Haskell" + FromCpp -> " from C++ to Haskell"] + case maybeGen of + Just (CustomConversion gen) -> do + LH.addImports $ hsImport1 "Prelude" "(>>=)" + LH.sayLn "(" + LH.indent gen + LH.saysLn [") ", fromVar, " >>= \\", toVar, " ->"] + Just BinaryCompatible -> LH.saysLn ["let ", toVar, " = ", fromVar, " in"] + Just ConversionUnsupported -> throwForNoConversion + Nothing -> throwForNoConversion + + where noConversion = LH.saysLn ["let ", toVar, " = ", fromVar, " in"] + +-- | Note that the 'CallDirection' is the direction of the call, not the +-- direction of the return. 'ToCpp' means we're returning to the foreign +-- language, 'FromCpp' means we're returning from it. +sayHsCallAndProcessReturn :: CallDirection -> Type -> [String] -> LH.Generator () +sayHsCallAndProcessReturn dir t callWords = + LH.withErrorContext ("processing return value of type " ++ show t) $ + case t of + Internal_TVoid -> sayCall + -- The same as TPtr (TConst (TObj _)), but nonconst. + Internal_TPtr (Internal_TObj cls) -> do + case dir of + ToCpp -> do + LH.addImports hsImportForPrelude + ctorName <- Class.toHsDataCtorName LH.Unmanaged Nonconst cls + LH.saysLn ["HoppyP.fmap ", ctorName] + sayCall + FromCpp -> do + LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + LH.sayLn "HoppyP.fmap HoppyFHR.toPtr" + sayCall + -- The same as TPtr (TConst (TObj _)), but nonconst. + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of + ToCpp -> do + LH.addImports hsImportForPrelude + ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls + LH.saysLn ["HoppyP.fmap ", ctorName] + sayCall + FromCpp -> do + LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + LH.sayLn "HoppyP.fmap HoppyFHR.toPtr" + sayCall + Internal_TPtr _ -> sayCall + Internal_TRef t' -> sayHsCallAndProcessReturn dir (ptrT t') callWords + Internal_TFn {} -> throwError "TFn unimplemented" + Internal_TObj cls -> case dir of + ToCpp -> case Class.classHaskellConversionFromCppFn $ LH.getClassHaskellConversion cls of + Just _ -> do + LH.addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], + hsImportForRuntime] + ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls + LH.saysLn ["(HoppyFHR.decodeAndDelete . ", ctorName, ") =<<"] + sayCall + Nothing -> + throwError $ concat + ["Can't return a TObj of ", show cls, + " from C++ to Haskell because no class decode conversion is defined"] + FromCpp -> do + LH.addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], + hsImportForPrelude, + hsImportForRuntime] + LH.sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<" + sayCall + Internal_TObjToHeap cls -> case dir of + ToCpp -> sayHsCallAndProcessReturn dir (ptrT $ objT cls) callWords + FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls + Internal_TToGc t' -> case dir of + ToCpp -> do + LH.addImports $ mconcat [hsImport1 "Prelude" "(=<<)", + hsImportForRuntime] + LH.sayLn "HoppyFHR.toGc =<<" + -- TToGc (TObj _) should create a pointer rather than decoding, so we + -- change the TObj _ into a TPtr (TObj _). + case t' of + Internal_TObj _ -> sayHsCallAndProcessReturn dir (ptrT t') callWords + _ -> sayHsCallAndProcessReturn dir t' callWords + FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' + Internal_TConst t' -> sayHsCallAndProcessReturn dir t' callWords + + Internal_TManual s -> do + -- Remember 'dir' is backward here, because we're dealing with a return + -- value, so these functions look backward. + let maybeGen = + fmap (case dir of + ToCpp -> conversionSpecHaskellFromCppFn + FromCpp -> conversionSpecHaskellToCppFn) $ + conversionSpecHaskell s + throwForNoConversion = + throwError $ concat + ["No conversion defined for ", show s, + case dir of + ToCpp -> " from C++ to Haskell" + FromCpp -> " to C++ from Haskell"] + case maybeGen of + Just (CustomConversion gen) -> do + LH.addImports $ hsImport1 "Prelude" "(=<<)" + LH.sayLn "(" + LH.indent gen + LH.sayLn ") =<<" + Just BinaryCompatible -> return () + Just ConversionUnsupported -> throwForNoConversion + Nothing -> throwForNoConversion + sayCall + + where sayCall = LH.saysLn $ "(" : callWords ++ [")"] + +-- | The Haskell type of a 'Function', as computed by 'fnToHsTypeAndUse'. This +-- combines a 'HsQualType' with a list of parameter names. +data FnHsType = FnHsType + { fnHsQualType :: HsQualType + , fnHsParamNameMaybes :: [Maybe String] + } + +-- | Implements special logic on top of 'LH.cppTypeToHsTypeAndUse', that +-- computes the Haskell __qualified__ type for a function, including typeclass +-- constraints, and bundles it with parameter names. +fnToHsTypeAndUse :: + LH.HsTypeSide + -> Purity + -> [Parameter] + -> Type + -> ExceptionHandlers + -- ^ These should be the effective exception handlers for the function, as + -- returned by + -- @'LH.getEffectiveExceptionHandlers' . 'fnExceptionHandlers'@, + -- not just the function's exception handlers directly from + -- @fnExceptionHandlers@. + -> LH.Generator FnHsType +fnToHsTypeAndUse side purity params returnType exceptionHandlers = do + let catches = not $ null $ exceptionHandlersList exceptionHandlers + getsExcParams = catches && side == LH.HsCSide + + paramTypes = + (if getsExcParams then (++ [ptrT intT, ptrT $ ptrT voidT]) else id) $ + map parameterType params + + paramNameMaybes = + (if getsExcParams then (++ [Just "excId", Just "excPtr"]) else id) $ + map parameterName params + + defaultParamNames = map LH.toArgName [1..] + + defaultedParamNames = zipWith fromMaybe defaultParamNames paramNameMaybes + + paramQualTypes <- mapM contextForParam $ zip defaultedParamNames paramTypes + let context = concatMap (\(HsQualType ctx _) -> ctx) paramQualTypes :: HsContext + hsParams = map (\(HsQualType _ t) -> t) paramQualTypes + + -- Determine the 'HsHsSide' return type for the function. Do the conversion + -- to a Haskell type, and wrap the result in 'IO' if the function is impure. + -- (HsCSide types always get wrapped in IO.) + hsReturnInitial <- LH.cppTypeToHsTypeAndUse side returnType + hsReturnForPurity <- case (purity, side) of + (Pure, LH.HsHsSide) -> return hsReturnInitial + _ -> do + LH.addImports hsImportForPrelude + return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnInitial + + return FnHsType + { fnHsQualType = HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams + , fnHsParamNameMaybes = paramNameMaybes + } + + where contextForParam :: (String, Type) -> LH.Generator HsQualType + contextForParam (s, t) = case t of + Internal_TPtr (Internal_TObj cls) -> receivePtr s cls Nonconst + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls + Internal_TRef (Internal_TObj cls) -> receivePtr s cls Nonconst + Internal_TRef (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls + Internal_TObj cls -> receiveValue s t cls + Internal_TManual spec -> + -- We add a typeclass constraint iff we're generating an exposed + -- Haskell function (HsHsSide) and there is a constraint declared. + -- If we're generating the underlying C FFI function, or if there is + -- no constraint declared, then don't add one. + case (side, conversionSpecHaskell spec >>= conversionSpecHaskellHsArgType) of + (LH.HsHsSide, Just f) -> f $ HsIdent s + _ -> handoff side t + Internal_TConst t' -> contextForParam (s, t') + _ -> handoff side t + + -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass + -- constraints. + handoff :: LH.HsTypeSide -> Type -> LH.Generator HsQualType + handoff side' t = HsQualType [] <$> LH.cppTypeToHsTypeAndUse side' t + + -- Receives a @FooPtr this => this@. + receivePtr :: String -> Class.Class -> Constness -> LH.Generator HsQualType + receivePtr s cls cst = case side of + LH.HsHsSide -> do + ptrClassName <- Class.toHsPtrClassName cst cls + let t' = HsTyVar $ HsIdent s + return $ HsQualType [(UnQual $ HsIdent ptrClassName, [t'])] t' + LH.HsCSide -> do + LH.addImports hsImportForForeign + typeName <- Class.toHsDataTypeName cst cls + return $ + HsQualType [] $ + HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") + (HsTyVar $ HsIdent typeName) + + -- Receives a @FooValue a => a@. + receiveValue :: String -> Type -> Class.Class -> LH.Generator HsQualType + receiveValue s t cls = case side of + LH.HsCSide -> handoff side t + LH.HsHsSide -> do + LH.addImports hsImportForRuntime + valueClassName <- Class.toHsValueClassName cls + let t' = HsTyVar $ HsIdent s + return $ HsQualType [(UnQual $ HsIdent valueClassName, [t'])] t' + +-- | Renders a 'FnHsType' as a Haskell type, ignoring parameter names. This +-- implementation uses haskell-src. +renderFnHsType :: FnHsType -> String +renderFnHsType = LH.prettyPrint . fnHsQualType + +-- | Renders a 'FnHsType' as a Haskell type, including Haddock for parameter +-- names. +-- +-- Unfortunately, we have to implement this ourselves, because haskell-src +-- doesn't support comments, and haskell-src-exts's comments implementation +-- relies on using specific source spans, and we don't want all that complexity +-- here. So instead we render it ourselves, inserting "{- ^ ... -}" tags where +-- appropriate. +renderFnHsTypeWithNames :: FnHsType -> String +renderFnHsTypeWithNames fnHsType = + concat $ renderedContextStrs ++ renderedParamStrs + + where HsQualType assts unqualType = fnHsQualType fnHsType + paramNameMaybes = fnHsParamNameMaybes fnHsType + + renderedContextStrs :: [String] + renderedContextStrs = + if null assts + then [] + else "(" : intersperse ", " (map renderAsst assts) ++ [") => "] + + renderAsst :: (HsQName, [HsType]) -> String + renderAsst asst = case asst of + (UnQual (HsIdent typeclass), [HsTyVar (HsIdent typeVar)]) -> + concat [typeclass, " ", typeVar] + _ -> error $ "renderAsst: Unexpected argument: " ++ show asst + + renderedParamStrs :: [String] + renderedParamStrs = renderParams unqualType paramNameMaybes + + renderParams :: HsType -> [Maybe String] -> [String] + renderParams fnType' paramNameMaybes' = case (fnType', paramNameMaybes') of + -- If there's a parameter name, then generate a Haddock comment + -- showing the name. + (HsTyFun a b, (Just name):restNames) -> + "(" : LH.prettyPrint a : ") {- ^ " : name : " -} -> " : renderParams b restNames + + -- If there's no parameter name, then don't generate any documentation + -- for it, but continue to recur in case there are other parameters + -- with names. + (HsTyFun a b, Nothing:restNames) -> + "(" : LH.prettyPrint a : ") -> " : renderParams b restNames + + -- If we've reached the end of the TyFun chain, then we don't need to + -- recur further. We can use 'prettyPrint' to render the rest. + _ -> "(" : LH.prettyPrint fnType' : [")"] diff --git a/src/Foreign/Hoppy/Generator/Spec/Function.hs-boot b/src/Foreign/Hoppy/Generator/Spec/Function.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Function.hs-boot @@ -0,0 +1,29 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +module Foreign.Hoppy.Generator.Spec.Function (fnT, fnT') where + +import Foreign.Hoppy.Generator.Spec.Base (Type, Parameter) + +-- | A function taking parameters and returning a value (or 'voidT'). Function +-- pointers must wrap a 'fnT' in a 'ptrT'. +-- +-- See also 'fnT'' which accepts parameter information. +fnT :: [Type] -> Type -> Type + +-- | A version of 'fnT' that accepts additional information about parameters. +fnT' :: [Parameter] -> Type -> Type diff --git a/src/Foreign/Hoppy/Generator/Spec/Variable.hs b/src/Foreign/Hoppy/Generator/Spec/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/Variable.hs @@ -0,0 +1,123 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Interface for defining bindings to C++ variables. +module Foreign.Hoppy.Generator.Spec.Variable ( + -- * Data type + Variable, + -- * Construction + makeVariable, + -- * Properties + varExtName, + varIdentifier, + varType, + varReqs, + varAddendum, + varIsConst, + varGetterExtName, + varSetterExtName, + ) where + +import Data.Function (on) +import Foreign.Hoppy.Generator.Spec.Base +import qualified Foreign.Hoppy.Generator.Spec.Class as Class +import qualified Foreign.Hoppy.Generator.Language.Cpp as LC +import qualified Foreign.Hoppy.Generator.Language.Haskell as LH + +-- | A C++ variable. +-- +-- Use this data type's 'HasReqs' instance to make the variable accessible. +data Variable = Variable + { varIdentifier :: Identifier + -- ^ The identifier used to refer to the variable. + , varExtName :: ExtName + -- ^ The variable's external name. + , varType :: Type + -- ^ The variable's type. This may be + -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is + -- read-only. + , varReqs :: Reqs + -- ^ Requirements for bindings to access this variable. + , varAddendum :: Addendum + -- ^ The variable's addendum. + } + +instance Eq Variable where + (==) = (==) `on` varExtName + +instance Show Variable where + show v = concat [""] + +instance Exportable Variable where + sayExportCpp = sayCppExport + sayExportHaskell = sayHsExport + +instance HasExtNames Variable where + getPrimaryExtName = varExtName + getNestedExtNames v = [varGetterExtName v, varSetterExtName v] + +instance HasReqs Variable where + getReqs = varReqs + setReqs reqs v = v { varReqs = reqs } + +instance HasAddendum Variable where + getAddendum = varAddendum + setAddendum addendum v = v { varAddendum = addendum } + +-- | Creates a binding for a C++ variable. +makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable +makeVariable identifier maybeExtName t = + Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty + +-- | Returns whether the variable is constant, i.e. whether its type is +-- @'Foreign.Hoppy.Generator.Types.constT' ...@. +varIsConst :: Variable -> Bool +varIsConst v = case varType v of + Internal_TConst _ -> True + _ -> False + +-- | Returns the external name of the getter function for the variable. +varGetterExtName :: Variable -> ExtName +varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName + +-- | Returns the external name of the setter function for the variable. +varSetterExtName :: Variable -> ExtName +varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName + +sayCppExport :: LC.SayExportMode -> Variable -> LC.Generator () +sayCppExport mode v = case mode of + LC.SayHeader -> return () + LC.SaySource -> + Class.sayCppExportVar (varType v) + Nothing + True + (varGetterExtName v) + (varSetterExtName v) + (LC.sayIdentifier $ varIdentifier v) + +sayHsExport :: LH.SayExportMode -> Variable -> LH.Generator () +sayHsExport mode v = LH.withErrorContext ("generating variable " ++ show (varExtName v)) $ do + let getterName = varGetterExtName v + setterName = varSetterExtName v + Class.sayHsExportVar mode + (varType v) + Nothing + True + getterName + getterName + setterName + setterName diff --git a/src/Foreign/Hoppy/Generator/Types.hs b/src/Foreign/Hoppy/Generator/Types.hs --- a/src/Foreign/Hoppy/Generator/Types.hs +++ b/src/Foreign/Hoppy/Generator/Types.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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 @@ -19,21 +19,33 @@ -- these functions, but we try to catch these and fail cleanly as much as -- possible. module Foreign.Hoppy.Generator.Types ( - -- * Primitive types + -- * Qualifiers + constT, + -- * Primtive types voidT, + ptrT, + refT, + fnT, + fnT', + -- * Numeric types boolT, + boolT', charT, ucharT, + wcharT, shortT, ushortT, intT, + intT', uintT, longT, ulongT, llongT, ullongT, floatT, + floatT', doubleT, + doubleT', int8T, int16T, int32T, @@ -45,125 +57,358 @@ ptrdiffT, sizeT, ssizeT, + -- ** Custom numeric types + makeNumericType, + convertByCoercingIntegral, + convertByCoercingFloating, -- * Complex types - enumT, - bitspaceT, - ptrT, - refT, - fnT, + manualT, callbackT, + enumT, objT, objToHeapT, toGcT, - constT, ) where +import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Callback (callbackT) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (Class) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Enum (enumT) +import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Function (fnT, fnT') import Foreign.Hoppy.Generator.Spec.Base +import Language.Haskell.Syntax ( + HsName (HsIdent), + HsQName (UnQual), + HsType (HsTyCon), + ) -- | C++ @void@, Haskell @()@. +voidT :: Type voidT = Internal_TVoid -- | C++ @bool@, Haskell 'Bool'. -boolT = Internal_TBool +-- +-- C++ has sizeof(bool) == 1, whereas Haskell can > 1, so we have to convert. +boolT :: Type +boolT = + makeNumericType "bool" mempty + (do LH.addImports hsImportForPrelude + return $ HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") + (Just $ do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CBool") + (CustomConversion $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude] + LH.sayLn "\\x -> HoppyP.return $ if x then 1 else 0") + (CustomConversion $ do + LH.addImports $ mconcat [hsImports "Prelude" ["(.)", "(/=)"], + hsImportForPrelude] + LH.sayLn "(HoppyP.return . (/= 0))") +-- | C++ @bool@, Haskell 'Foreign.C.CBool'. +boolT' :: Type +boolT' = + makeNumericType "bool" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CBool") + Nothing BinaryCompatible BinaryCompatible + -- | C++ @char@, Haskell 'Foreign.C.CChar'. -charT = Internal_TChar +charT :: Type +charT = + makeNumericType "char" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CChar") + Nothing BinaryCompatible BinaryCompatible -- | C++ @unsigned char@, Haskell 'Foreign.C.CUChar'. -ucharT = Internal_TUChar +ucharT :: Type +ucharT = + makeNumericType "unsigned char" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CUChar") + Nothing BinaryCompatible BinaryCompatible +-- | C++ @wchar_t@, Haskell 'Foreign.C.CWchar'. +wcharT :: Type +wcharT = + makeNumericType "wchar_t" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CWchar") + Nothing BinaryCompatible BinaryCompatible + -- | C++ @short int@, Haskell 'Foreign.C.CShort'. -shortT = Internal_TShort +shortT :: Type +shortT = + makeNumericType "short" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CShort") + Nothing BinaryCompatible BinaryCompatible -- | C++ @unsigned short int@, Haskell 'Foreign.C.CUShort'. -ushortT = Internal_TUShort +ushortT :: Type +ushortT = + makeNumericType "unsigned short" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CUShort") + Nothing BinaryCompatible BinaryCompatible --- | C++ @int@, Haskell 'Foreign.C.CInt'. -intT = Internal_TInt +-- | C++ @int@, Haskell 'Int'. See also 'intT''. +intT :: Type +intT = + makeNumericType "int" mempty + (do LH.addImports hsImportForPrelude + return $ HsTyCon $ UnQual $ HsIdent "HoppyP.Int") + (Just $ do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CInt") + convertByCoercingIntegral convertByCoercingIntegral +-- | C++ @int@, Haskell 'Foreign.C.CInt'. See also 'intT'. +intT' :: Type +intT' = + makeNumericType "int" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CInt") + Nothing BinaryCompatible BinaryCompatible + -- | C++ @unsigned int@, Haskell 'Foreign.C.CUInt'. -uintT = Internal_TUInt +uintT :: Type +uintT = + makeNumericType "unsigned int" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CUInt") + Nothing BinaryCompatible BinaryCompatible -- | C++ @long int@, Haskell 'Foreign.C.CLong'. -longT = Internal_TLong +longT :: Type +longT = + makeNumericType "long" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CLong") + Nothing BinaryCompatible BinaryCompatible -- | C++ @unsigned long int@, Haskell 'Foreign.C.CULong'. -ulongT = Internal_TULong +ulongT :: Type +ulongT = + makeNumericType "unsigned long" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CULong") + Nothing BinaryCompatible BinaryCompatible -- | C++ @long long int@, Haskell 'Foreign.C.CLLong'. -llongT = Internal_TLLong +llongT :: Type +llongT = + makeNumericType "long long" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CLLong") + Nothing BinaryCompatible BinaryCompatible -- | C++ @unsigned long long int@, Haskell 'Foreign.C.CULLong'. -ullongT = Internal_TULLong +ullongT :: Type +ullongT = + makeNumericType "unsigned long long" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CULLong") + Nothing BinaryCompatible BinaryCompatible --- | C++ @float@, Haskell 'Foreign.C.CFloat'. -floatT = Internal_TFloat +-- | C++ @float@, Haskell 'Prelude.Float'. See also 'floatT''. +floatT :: Type +floatT = + makeNumericType "float" mempty + (do LH.addImports hsImportForPrelude + return $ HsTyCon $ UnQual $ HsIdent "HoppyP.Float") + (Just $ do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CFloat") + convertByCoercingFloating convertByCoercingFloating --- | C++ @double@, Haskell 'Foreign.C.CDouble'. -doubleT = Internal_TDouble +-- | C++ @float@, Haskell 'Foreign.C.CFloat'. See also 'floatT'. +floatT' :: Type +floatT' = + makeNumericType "float" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "Foreign.C.CFloat") + Nothing BinaryCompatible BinaryCompatible +-- | C++ @double@, Haskell 'Prelude.Double'. See also 'doubleT''. +doubleT :: Type +doubleT = + makeNumericType "double" mempty + (do LH.addImports hsImportForPrelude + return $ HsTyCon $ UnQual $ HsIdent "HoppyP.Double") + (Just $ do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CDouble") + convertByCoercingFloating convertByCoercingFloating + +-- | C++ @double@, Haskell 'Foreign.C.CDouble'. See also 'doubleT'. +doubleT' :: Type +doubleT' = + makeNumericType "double" mempty + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "Foreign.C.CDouble") + Nothing BinaryCompatible BinaryCompatible + -- | C++ @int8_t@, Haskell 'Data.Int.Int8'. -int8T = Internal_TInt8 +int8T :: Type +int8T = + makeNumericType "int8_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForInt + return $ HsTyCon $ UnQual $ HsIdent "HoppyDI.Int8") + Nothing BinaryCompatible BinaryCompatible -- | C++ @int16_t@, Haskell 'Data.Int.Int16'. -int16T = Internal_TInt16 +int16T :: Type +int16T = + makeNumericType "int16_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForInt + return $ HsTyCon $ UnQual $ HsIdent "HoppyDI.Int16") + Nothing BinaryCompatible BinaryCompatible -- | C++ @int32_t@, Haskell 'Data.Int.Int32'. -int32T = Internal_TInt32 +int32T :: Type +int32T = + makeNumericType "int32_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForInt + return $ HsTyCon $ UnQual $ HsIdent "HoppyDI.Int32") + Nothing BinaryCompatible BinaryCompatible -- | C++ @int64_t@, Haskell 'Data.Int.Int64'. -int64T = Internal_TInt64 +int64T :: Type +int64T = + makeNumericType "int64_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForInt + return $ HsTyCon $ UnQual $ HsIdent "HoppyDI.Int64") + Nothing BinaryCompatible BinaryCompatible -- | C++ @uint8_t@, Haskell 'Data.Word.Word8'. -word8T = Internal_TWord8 +word8T :: Type +word8T = + makeNumericType "uint8_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForWord + return $ HsTyCon $ UnQual $ HsIdent "HoppyDW.Word8") + Nothing BinaryCompatible BinaryCompatible -- | C++ @uint16_t@, Haskell 'Data.Word.Word16'. -word16T = Internal_TWord16 +word16T :: Type +word16T = + makeNumericType "uint16_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForWord + return $ HsTyCon $ UnQual $ HsIdent "HoppyDW.Word16") + Nothing BinaryCompatible BinaryCompatible -- | C++ @uint32_t@, Haskell 'Data.Word.Word32'. -word32T = Internal_TWord32 +word32T :: Type +word32T = + makeNumericType "uint32_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForWord + return $ HsTyCon $ UnQual $ HsIdent "HoppyDW.Word32") + Nothing BinaryCompatible BinaryCompatible -- | C++ @uint64_t@, Haskell 'Data.Word.Word64'. -word64T = Internal_TWord64 +word64T :: Type +word64T = + makeNumericType "uint64_t" (reqInclude $ includeStd "cstdint") + (do LH.addImports hsImportForWord + return $ HsTyCon $ UnQual $ HsIdent "HoppyDW.Word64") + Nothing BinaryCompatible BinaryCompatible -- | C++ @ptrdiff_t@, Haskell 'Foreign.C.CPtrdiff'. -ptrdiffT = Internal_TPtrdiff +ptrdiffT :: Type +ptrdiffT = + makeNumericType "ptrdiff_t" (reqInclude $ includeStd "cstddef") + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CPtrdiff") + Nothing BinaryCompatible BinaryCompatible -- | C++ @size_t@, Haskell 'Foreign.C.CSize'. -sizeT = Internal_TSize +sizeT :: Type +sizeT = + makeNumericType "size_t" (reqInclude $ includeStd "cstddef") + (do LH.addImports hsImportForForeignC + return $ HsTyCon $ UnQual $ HsIdent "HoppyFC.CSize") + Nothing BinaryCompatible BinaryCompatible -- | C++ @ssize_t@, Haskell 'System.Posix.Types.CSsize'. -ssizeT = Internal_TSSize +ssizeT :: Type +ssizeT = + makeNumericType "ssize_t" (reqInclude $ includeStd "cstddef") + (do LH.addImports hsImportForSystemPosixTypes + return $ HsTyCon $ UnQual $ HsIdent "HoppySPT.CSsize") + Nothing BinaryCompatible BinaryCompatible --- | A C++ @enum@ value. -enumT = Internal_TEnum +-- | Builds a new numeric type definition. +-- +-- For convenience, 'convertByCoercingIntegral' and 'convertByCoercingFloating' +-- may be used as conversion methods, for both 'ConversionMethod' arguments this +-- function takes. +makeNumericType :: + String + -- ^ The name of the C++ type. + -> Reqs + -- ^ Includes necessary to use the C++ type. + -> LH.Generator HsType + -- ^ Generator for rendering the Haskell type to be used, along with any + -- required imports. See 'conversionSpecHaskellHsType'. + -> Maybe (LH.Generator HsType) + -- ^ If there is a Haskell type distinct from the previous argument to be + -- used for passing over the FFI boundary, then provide it here. See + -- 'conversionSpecHaskellCType'. + -> ConversionMethod (LH.Generator ()) + -- ^ Method to use to convert a Haskell value to a value to be passed over + -- the FFI. See 'conversionSpecHaskellToCppFn'. + -> ConversionMethod (LH.Generator ()) + -- ^ Method to use to convert a value received over the FFI into a Haskell + -- value. See 'conversionSpecHaskellFromCppFn'. + -> Type +makeNumericType cppName cppReqs hsTypeGen hsCTypeGen convertToCpp convertFromCpp = + Internal_TManual spec + where spec = + (makeConversionSpec cppName $ makeConversionSpecCpp cppName $ return cppReqs) + { conversionSpecHaskell = + Just $ makeConversionSpecHaskell + hsTypeGen + hsCTypeGen + convertToCpp + convertFromCpp + } --- | A C++ bitspace value. -bitspaceT = Internal_TBitspace +-- | Conversion method for passing a numeric values to and from Haskell by using +-- @Foreign.Hoppy.Runtime.coerceIntegral@. +convertByCoercingIntegral :: ConversionMethod (LH.Generator ()) +convertByCoercingIntegral = CustomConversion $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude, + hsImportForRuntime] + LH.sayLn "HoppyP.return . HoppyFHR.coerceIntegral" +-- | Conversion method for passing a numeric values to and from Haskell by using +-- 'realToFrac'. +convertByCoercingFloating :: ConversionMethod (LH.Generator ()) +convertByCoercingFloating = CustomConversion $ do + LH.addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForPrelude] + LH.sayLn "HoppyP.return . HoppyP.realToFrac" + -- | A pointer to another type. +ptrT :: Type -> Type ptrT = Internal_TPtr -- | A reference to another type. +refT :: Type -> Type refT = Internal_TRef --- | A function taking parameters and returning a value (or 'voidT'). Function --- pointers must wrap a 'fnT' in a 'ptrT'. -fnT = Internal_TFn - --- | A handle for calling foreign code from C++. -callbackT = Internal_TCallback - -- | An instance of a class. When used in a parameter or return type and not -- wrapped in a 'ptrT' or 'refT', this is a by-value object. +objT :: Class -> Type objT = Internal_TObj -- | A special case of 'objT' that is only allowed when passing objects from -- C++ to a foreign language. Rather than looking at the object's --- 'ClassConversion', the object will be copied to the heap, and a pointer to --- the heap object will be passed. The object must be copy-constructable. +-- 'Foreign.Hoppy.Generator.Spec.Class.ClassConversion', the object will be +-- copied to the heap, and a pointer to the heap object will be passed. The +-- object must be copy-constructable. -- -- __The foreign language owns the pointer, even for callback arguments.__ +objToHeapT :: Class -> Type objToHeapT = Internal_TObjToHeap -- | This type transfers ownership of the object to the foreign language's @@ -179,7 +424,13 @@ -- - @'toGcT' ('refT' ('objT' cls))@ -- - @'toGcT' ('ptrT' ('constT' ('objT' cls)))@ -- - @'toGcT' ('ptrT' ('objT' cls))@ +toGcT :: Type -> Type toGcT = Internal_TToGc +-- | Constructs a type from a specification of how to convert values. +manualT :: ConversionSpec -> Type +manualT = Internal_TManual + -- | A @const@ version of another type. +constT :: Type -> Type constT = Internal_TConst diff --git a/src/Foreign/Hoppy/Generator/Util.hs b/src/Foreign/Hoppy/Generator/Util.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Util.hs @@ -0,0 +1,115 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2019 Bryan Gardiner +-- +-- 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 . + +-- | Miscellaneous utilities that may be useful in Hoppy generators. +module Foreign.Hoppy.Generator.Util ( + -- * String utilities + splitIntoWords, + -- * File utilities + withTempFile, + withTempDirectory, + ) where + +import Control.Exception (IOException, catch, throwIO) +import Control.Monad (when) +import Data.Char (isDigit, isLetter, isLower, isUpper) +import System.Directory ( + doesDirectoryExist, + doesFileExist, + getTemporaryDirectory, + removeFile, + removeDirectoryRecursive, + ) +import System.IO (Handle, openTempFile) +import System.IO.Temp (createTempDirectory) + +-- | Splits a C++ identifier string into multiple words, doing smart inspection +-- of the case convention of the string. This supports @snake_case@ and +-- @CONSTANT_CASE@, and recognition of @camelCase@, including when acronyms are +-- uppercased (@\"HTMLElement\"@ gives @[\"HTML\", \"Element\"]@). Numbers are +-- treated as their own words, and non-alphanumeric characters are treated as +-- word separators and dropped. +splitIntoWords :: String -> [String] +splitIntoWords cs = case cs of + "" -> [] + + -- The case of multiple upper-case letters, e.g. "HTML", or "HTMLElement". + c1:c2:_ | isUpper c1 && isUpper c2 -> + let (upperWord, rest) = span isUpper cs + (upperWord', rest') = case rest of + -- This handles the "HTMLElement" case, where we need to shift from + -- "HTMLE"/"lement" to "HTML"/"Element". + c3:_ | isLower c3 -> + let (word, lastChar) = splitAt (length upperWord - 1) upperWord + in (word, lastChar ++ rest) + -- But if the part after the upper case part doesn't start with a + -- lower case letter, then there's no rearranging to do. + _ -> (upperWord, rest) + in upperWord' : splitIntoWords rest' + + -- The case of letters, but not multiple upper case letters. Here we want to + -- take grab "foo" from "fooBar", "a" from "aWidget", and "Too" from "TooNie". + c1:cs' | isLetter c1 -> + let (wordTail, rest) = span isLower cs' + in (c1:wordTail) : splitIntoWords rest + + -- Numbers get treated as their own words. + c1:_ | isDigit c1 -> + let (word, rest) = span isDigit cs + in word : splitIntoWords rest + + -- Non-alphanumeric characters may act as word barriers, but otherwise get + -- dropped. + _:cs' -> splitIntoWords cs' + +-- | Creates a temporary file whose name is based on the given template string, +-- and runs the given function with the path to the file. The file is deleted +-- when the function completes, if the boolean that the function returns (or, in +-- case of an exception, the boolean that was passed directly to 'withTempFile') +-- is true. +withTempFile :: String -> Bool -> (FilePath -> Handle -> IO (Bool, a)) -> IO a +withTempFile template deleteOnException f = do + tempDir <- getTemporaryDirectory + (path, handle) <- openTempFile tempDir template + catch (do (delete, result) <- f path handle + when delete $ removeFileIfExists path + return result) + (\(e :: IOException) -> do + when deleteOnException $ removeFileIfExists path + throwIO e) + where removeFileIfExists path = do + exists <- doesFileExist path + when exists $ removeFile path + +-- | Creates a temporary directory whose name is based on the given template +-- string, and runs the given function with the directory's path. The directory +-- is deleted when the function completes, if the boolean that the function +-- returns (or, in case of an exception, the boolean that was passed directly to +-- 'withTempDirectory') is true. +withTempDirectory :: String -> Bool -> (FilePath -> IO (Bool, a)) -> IO a +withTempDirectory template deleteOnException f = do + outerDir <- getTemporaryDirectory + dir <- createTempDirectory outerDir template + catch (do (delete, result) <- f dir + when delete $ removeIfExists dir + return result) + (\(e :: IOException) -> do + when deleteOnException $ removeIfExists dir + throwIO e) + where removeIfExists dir = do + exists <- doesDirectoryExist dir + when exists $ removeDirectoryRecursive dir diff --git a/src/Foreign/Hoppy/Generator/Version.hs b/src/Foreign/Hoppy/Generator/Version.hs --- a/src/Foreign/Hoppy/Generator/Version.hs +++ b/src/Foreign/Hoppy/Generator/Version.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2018 Bryan Gardiner +-- Copyright 2015-2019 Bryan Gardiner -- -- 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