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 2016 Bryan Gardiner +-- Copyright 2016-2017 Bryan Gardiner -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. diff --git a/hoppy-runtime.cabal b/hoppy-runtime.cabal --- a/hoppy-runtime.cabal +++ b/hoppy-runtime.cabal @@ -1,12 +1,12 @@ name: hoppy-runtime -version: 0.3.0 +version: 0.3.1 synopsis: C++ FFI generator - Runtime support homepage: http://khumba.net/projects/hoppy license: Apache-2.0 license-file: LICENSE author: Bryan Gardiner maintainer: Bryan Gardiner -copyright: Copyright 2015-2016 Bryan Gardiner +copyright: Copyright 2015-2017 Bryan Gardiner category: Foreign build-type: Simple cabal-version: >=1.10 @@ -19,6 +19,7 @@ library exposed-modules: Foreign.Hoppy.Runtime + , Foreign.Hoppy.Setup default-extensions: DeriveDataTypeable , ExistentialQuantification @@ -29,7 +30,10 @@ , ScopedTypeVariables build-depends: base >=4.7 && <5 + , Cabal >=1.20 && <1.25 , containers >=0.5 && <0.6 + , directory >=1.2 && <1.4 + , filepath >=1.3 && <1.5 hs-source-dirs: src ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind default-language: Haskell2010 diff --git a/src/Foreign/Hoppy/Runtime.hs b/src/Foreign/Hoppy/Runtime.hs --- a/src/Foreign/Hoppy/Runtime.hs +++ b/src/Foreign/Hoppy/Runtime.hs @@ -1,6 +1,6 @@ -- This file is part of Hoppy. -- --- Copyright 2015-2016 Bryan Gardiner +-- Copyright 2015-2017 Bryan Gardiner -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -124,19 +124,21 @@ else error $ "Conversion from " ++ show (typeOf a) ++ " to " ++ show (typeOf b) ++ " does not preserve the value " ++ show a ++ "." --- | An instance of this class represents a pointer to a C++ object. All C++ --- classes bound by Hoppy have instances of @CppPtr@. The lifetime of such an --- object can optionally be managed by the Haskell garbage collector. Pointers --- returned from constructors are unmanaged, and 'toGc' converts an unmanaged --- pointer to a managed one. 'delete' must not be called on managed pointers. +-- | An instance of this class represents a handle (a pointer) to a C++ object. +-- All C++ classes bound by Hoppy have instances of @CppPtr@. The lifetime of +-- such an object can optionally be managed by the Haskell garbage collector. +-- Handles returned from constructors are unmanaged, and 'toGc' converts an +-- unmanaged handle to a managed one. 'delete' must not be called on managed +-- handles. class CppPtr this where - -- | Polymorphic null pointer. + -- | Polymorphic null pointer handle. nullptr :: this - -- | Runs an IO action on the 'Ptr' underlying this pointer. Equivalent to - -- 'ForeignPtr.withForeignPtr' for managed pointers: the 'Ptr' is only + -- | Runs an IO action on the 'Ptr' underlying this handle. Equivalent to + -- 'ForeignPtr.withForeignPtr' for managed handles: the 'Ptr' is only -- guaranteed to be valid until the action returns. There is no such - -- restriction for unmanaged pointers. + -- restriction for unmanaged handles, but of course the object must still be + -- alive to be used. withCppPtr :: this -> (Ptr this -> IO a) -> IO a -- | Converts to a regular pointer. For objects managed by the garbage @@ -146,8 +148,8 @@ -- 'touchCppPtr' call later on. toPtr :: this -> Ptr this - -- | Equivalent to 'ForeignPtr.touchForeignPtr' for managed object pointers. - -- Has no effect on unmanaged pointers. + -- | Equivalent to 'ForeignPtr.touchForeignPtr' for managed handles. Has no + -- effect on unmanaged handles. touchCppPtr :: this -> IO () -- | C++ values that can be deleted. By default, C++ classes bound by Hoppy are @@ -156,18 +158,20 @@ -- | Deletes the object with the C++ @delete@ operator. delete :: this -> IO () - -- | Converts a pointer to one managed by the garbage collector. A __new__ - -- managed pointer is returned, and existing pointers __including__ the - -- argument remain unmanaged, becoming invalid once all managed pointers are - -- unreachable. Calling this on an already managed pointer has no effect and + -- | Converts a handle to one managed by the garbage collector. A __new__ + -- managed handle is returned, and existing handles __including__ the + -- argument remain unmanaged, becoming invalid once all managed handles are + -- unreachable. Calling this on an already managed handle has no effect and -- the argument is simply returned. It is no longer safe to call 'delete' on -- the given object after calling this function. It is also not safe to call - -- this function on unmanaged pointers for a single object multiple times: the + -- this function on unmanaged handles for a single object multiple times: the -- object will get deleted more than once. + -- + -- Up- and downcasting managed handles keeps the object alive correctly. toGc :: this -> IO this -- | A typeclass for references to C++ values that can be assigned to. This --- includes raw pointers ('Ptr'), as well as pointers to object types that have +-- includes raw pointers ('Ptr'), as well as handles for object types that have -- an assignment operator (see -- 'Foreign.Hoppy.Generator.Spec.ClassFeature.Assignable'). class Assignable cppType value where @@ -214,8 +218,8 @@ encode :: hsType -> IO cppPtrType -- | Takes a dummy argument to help with type resolution of 'encode', a la --- 'asTypeOf'. For example, for a C++ pointer type @StdString@ that gets --- converted to a regular haskell 'String', the expected usage is: +-- 'asTypeOf'. For example, for a handle type @StdString@ that gets converted +-- to a regular haskell 'String', the expected usage is: -- -- > str :: String -- > encodeAs (undefined :: StdString) str @@ -303,15 +307,16 @@ => hsType -> (cppPtrType -> IO a) -> IO a withCppObj x = bracket (encode x) delete --- | @withScopedPtr m f@ runs @m@ to get a pointer, which is given to @f@ to --- execute. When @f@ finishes, the pointer is deleted (via 'bracket'). +-- | @withScopedPtr m f@ runs @m@ to get a handle, which is given to @f@ to +-- execute. When @f@ finishes, the handle is deleted (via 'bracket' and +-- 'delete'). withScopedPtr :: Deletable cppPtrType => IO cppPtrType -> (cppPtrType -> IO a) -> IO a withScopedPtr p = bracket p delete -- | @withScopedFunPtr m f@ runs @m@ to get a 'FunPtr', which is given to @f@ to --- execute. When @f@ finishes, the 'FunPtr' is deleted (via 'bracket'). This --- is useful in conjunction with function pointers created via generated --- callback functions. +-- execute. When @f@ finishes, the 'FunPtr' is deleted (via 'bracket' and +-- 'freeHaskellFunPtr'). This is useful in conjunction with function pointers +-- created via generated callback functions. withScopedFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b withScopedFunPtr p = bracket p freeHaskellFunPtr @@ -328,12 +333,10 @@ -- | Internal. Returns metadata about the exception. cppExceptionInfo :: e -> ExceptionClassInfo - -- | Internal. Constructs an object handle from a GC-managed object's raw - -- pointers. + -- | Internal. Constructs a handle from a GC-managed object's raw pointers. cppExceptionBuild :: ForeignPtr () -> Ptr () -> e - -- | Internal. Constructs a GC-managed object handle from an unmanaged raw - -- pointer. + -- | Internal. Constructs a GC-managed handle from an unmanaged raw pointer. cppExceptionBuildToGc :: Ptr () -> IO e -- | A typeclass for C++ values that are throwable as exceptions. C++ classes that @@ -402,7 +405,7 @@ instance CppException UnknownCppException where cppExceptionInfo _ = ExceptionClassInfo { exceptionClassId = ExceptionId 1 - , exceptionClassName = "" + , exceptionClassName = "" , exceptionClassUpcasts = M.empty , exceptionClassDelete = error "UnknownCppException.exceptionClassDelete: Should not get here." , exceptionClassCopy = error "UnknownCppException.exceptionClassCopy: Should not get here." diff --git a/src/Foreign/Hoppy/Setup.hs b/src/Foreign/Hoppy/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Setup.hs @@ -0,0 +1,369 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2017 Bryan Gardiner +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE CPP #-} + +-- | Implementations of Cabal setup programs for use in packages of generated +-- bindings. +-- +-- Much like the default Setup.hs that Cabal recommends for packages, +-- +-- @ +-- import "Distribution.Simple" +-- main = 'Distribution.Simple.defaultMain' +-- @ +-- +-- this module provides simplified configuration of packages for generated +-- bindings. Suppose you have a project named foobar that is composed of Cabal +-- packages named \"foobar-generator\" for the code generator, \"foobar-cpp\" +-- for the C++ gateway, and \"foobar\" for the Haskell gateway. The C++ gateway +-- package can use the following code: +-- +-- @ +-- import "Foreign.Hoppy.Setup" ('ProjectConfig' (..), 'cppMain') +-- +-- main = +-- cppMain $ +-- ProjectConfig +-- { generatorExecutableName = "foobar-generator" +-- , cppPackageName = "foobar-cpp" +-- , cppSourcesDir = "cpp" +-- , hsSourcesDir = "src" +-- } +-- @ +-- +-- The Haskell gateway uses the same code, except calling 'hsMain' instead of +-- 'cppMain'. This causes C++ sources to be generated in @foobar-cpp\/cpp@ and +-- (assuming the Haskell gateway is at @foobar\/@) the Haskell sources to be +-- generated in @foobar\/src@. +-- +-- The gateway packages need to set @build-type: Custom@ in their @.cabal@ files +-- to use these setup files. +module Foreign.Hoppy.Setup ( + ProjectConfig (..), + cppMain, + cppUserHooks, + hsMain, + hsUserHooks, + ) where + +import Control.Monad (forM_, unless, when) +import Data.List (isInfixOf) +import Distribution.InstalledPackageInfo (libraryDirs) +import Distribution.Package (PackageName (PackageName)) +import Distribution.PackageDescription ( + HookedBuildInfo, + PackageDescription, + emptyBuildInfo, + extraLibDirs, + ) +import Distribution.Simple (defaultMainWithHooks, simpleUserHooks) +import Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo, + absoluteInstallDirs, + installedPkgs, + libdir, + withPrograms, + ) +import Distribution.Simple.PackageIndex (lookupPackageName) +import Distribution.Simple.Program ( + getProgramOutput, + runDbProgram, + runProgram, + ) +import Distribution.Simple.Program.Find ( + ProgramSearchPathEntry (ProgramSearchPathDefault), + findProgramOnSearchPath, + ) +import Distribution.Simple.Program.Types ( + ConfiguredProgram, + Program, + ProgramLocation (FoundOnSystem), + simpleConfiguredProgram, + simpleProgram, + ) +import Distribution.Simple.Setup ( + CopyDest (CopyTo, NoCopyDest), + buildVerbosity, + cleanVerbosity, + configVerbosity, + copyDest, + copyVerbosity, + flagToMaybe, + fromFlagOrDefault, + installDistPref, + installVerbosity, + ) +import Distribution.Simple.UserHooks ( + UserHooks ( + buildHook, + hookedPrograms, + cleanHook, + copyHook, + instHook, + postConf, + preBuild, + preCopy, + preInst, + preReg, + preTest + ), + ) +import Distribution.Simple.Utils (die, info) +import Distribution.Verbosity (Verbosity, normal) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.FilePath ((), takeDirectory) + +data Language = Cpp | Haskell + +-- | Configuration parameters for a project using Hoppy. +data ProjectConfig = ProjectConfig + { generatorExecutableName :: FilePath + -- ^ The name of the executable program in the generator package. + , cppPackageName :: String + -- ^ The name of the C++ gateway package. + , cppSourcesDir :: FilePath + -- ^ The directory into which to generate C++ sources, under the C++ gateway + -- package root. + , hsSourcesDir :: FilePath + -- ^ The directory into which to generate Haskell sources, under the Haskell + -- gateway package root. + } + +getGeneratorProgram :: ProjectConfig -> Program +getGeneratorProgram project = simpleProgram $ generatorExecutableName project + +-- | A @main@ implementation to be used in the @Setup.hs@ of a C++ gateway +-- package. +-- +-- @cppMain project = 'defaultMainWithHooks' $ 'cppUserHooks' project@ +cppMain :: ProjectConfig -> IO () +cppMain project = defaultMainWithHooks $ cppUserHooks project + +-- | Cabal user hooks for a C++ gateway package. When overriding fields in the +-- result, be sure to call the previous hook. +-- +-- The following hooks are defined: +-- +-- - 'postConf': Runs the generator program to generate C++ sources. Checks if +-- a @configure@ script exists in the C++ gateway root, and calls it if so +-- (without arguments). +-- +-- - 'buildHook': Runs @make@ with no arguments from the C++ gateway root. +-- +-- - 'copyHook' and 'instHook': Runs @make install libdir=$libdir@ where +-- @$libdir@ is the directory into which to install the built shared library. +-- +-- - 'cleanHook': Removes files created by the generator, then calls @make +-- clean@. +cppUserHooks :: ProjectConfig -> UserHooks +cppUserHooks project = + simpleUserHooks + { hookedPrograms = [generatorProgram, makeProgram] + + , postConf = \args flags pkgDesc localBuildInfo -> do + let verbosity = fromFlagOrDefault normal $ configVerbosity flags + cppConfigure project verbosity localBuildInfo generatorProgram + postConf simpleUserHooks args flags pkgDesc localBuildInfo + + , buildHook = \pkgDesc localBuildInfo hooks flags -> do + buildHook simpleUserHooks pkgDesc localBuildInfo hooks flags + let verbosity = fromFlagOrDefault normal $ buildVerbosity flags + cppBuild verbosity localBuildInfo + + , copyHook = \pkgDesc localBuildInfo hooks flags -> do + copyHook simpleUserHooks pkgDesc localBuildInfo hooks flags + let verbosity = fromFlagOrDefault normal $ copyVerbosity flags + dest = fromFlagOrDefault NoCopyDest $ copyDest flags + cppInstall verbosity pkgDesc localBuildInfo dest + + , instHook = \pkgDesc localBuildInfo hooks flags -> do + instHook simpleUserHooks pkgDesc localBuildInfo hooks flags + let verbosity = fromFlagOrDefault normal $ installVerbosity flags + dest = maybe NoCopyDest CopyTo $ + flagToMaybe $ installDistPref flags + cppInstall verbosity pkgDesc localBuildInfo dest + + , cleanHook = \pkgDesc z hooks flags -> do + cleanHook simpleUserHooks pkgDesc z hooks flags + let verbosity = fromFlagOrDefault normal $ cleanVerbosity flags + cppClean project verbosity + } + + where generatorProgram = getGeneratorProgram project + +makeProgram :: Program +makeProgram = simpleProgram "make" + +cppConfigure :: ProjectConfig -> Verbosity -> LocalBuildInfo -> Program -> IO () +cppConfigure project verbosity localBuildInfo generatorProgram = do + -- Invoke the generator to create C++ code. + let programDb = withPrograms localBuildInfo + sourcesDir = cppSourcesDir project + createDirectoryIfMissing True sourcesDir + runDbProgram verbosity generatorProgram programDb ["--gen-cpp", sourcesDir] + + -- When there is a configure script, then run it. + maybeConfigureProgram <- findConfigure + case maybeConfigureProgram of + Just configureProgram -> runProgram verbosity configureProgram [] + Nothing -> return () + + where findConfigure :: IO (Maybe ConfiguredProgram) + findConfigure = do + hasConfigure <- doesFileExist "configure" + return $ if hasConfigure + then Just $ simpleConfiguredProgram "configure" $ FoundOnSystem "./configure" + else Nothing + +cppBuild :: Verbosity -> LocalBuildInfo -> IO () +cppBuild verbosity localBuildInfo = do + hasMakefile <- doesFileExist "Makefile" + unless hasMakefile $ die "No Makefile found." + let programDb = withPrograms localBuildInfo + runDbProgram verbosity makeProgram programDb [] + +cppInstall :: Verbosity -> PackageDescription -> LocalBuildInfo -> CopyDest -> IO () +cppInstall verbosity pkgDesc localBuildInfo dest = do + hasMakefile <- doesFileExist "Makefile" + unless hasMakefile $ die "No Makefile found." + let programDb = withPrograms localBuildInfo + libDir = libdir $ absoluteInstallDirs pkgDesc localBuildInfo dest + createDirectoryIfMissing True libDir + runDbProgram verbosity makeProgram programDb ["install", "libdir=" ++ libDir] + +cppClean :: ProjectConfig -> Verbosity -> IO () +cppClean project verbosity = do + removeGeneratedFiles Cpp project verbosity + + hasMakefile <- doesFileExist "Makefile" + unless hasMakefile $ die "No Makefile found." + makeProgram <- findSystemProgram verbosity "make" + runProgram verbosity makeProgram ["clean"] + +findSystemProgram :: Verbosity -> FilePath -> IO ConfiguredProgram +findSystemProgram verbosity basename = do + maybePath <- +#if MIN_VERSION_Cabal(1,24,0) + fmap (fmap fst) $ -- We don't care about failed search paths. +#endif + findProgramOnSearchPath verbosity [ProgramSearchPathDefault] basename + case maybePath of + Just path -> return $ simpleConfiguredProgram basename $ FoundOnSystem path + Nothing -> die $ "Couldn't find program " ++ show basename ++ "." + +-- | A @main@ implementation to be used in the @Setup.hs@ of a Haskell gateway +-- package. +-- +-- @hsMain project = 'defaultMainWithHooks' $ 'hsUserHooks' project@ +hsMain :: ProjectConfig -> IO () +hsMain project = defaultMainWithHooks $ hsUserHooks project + +-- | Cabal user hooks for a Haskell gateway package. When overriding fields in +-- the result, be sure to call the previous hook. +-- +-- The following hooks are defined: +-- +-- - 'postConf': Finds the shared library directory for the installed C++ +-- gateway package, and writes this path to a @dist\/build\/hoppy-cpp-libdir@ +-- file. Runs the generator program to generate Haskell sources. +-- +-- - 'preBuild', 'preTest', 'preCopy', 'preInst', 'preReg': Reads the C++ +-- library directory from @dist\/build\/hoppy-cpp-libdir@ and adds it to the +-- library search path ('extraLibDirs'). +-- +-- - 'cleanHook': Removes files created by the generator. +hsUserHooks :: ProjectConfig -> UserHooks +hsUserHooks project = + simpleUserHooks + { hookedPrograms = [generatorProgram] + + , postConf = \args flags pkgDesc localBuildInfo -> do + postConf simpleUserHooks args flags pkgDesc localBuildInfo + let verbosity = fromFlagOrDefault normal $ configVerbosity flags + hsConfigure project verbosity localBuildInfo generatorProgram + + , preBuild = \_ _ -> addLibDir + , preTest = \_ _ -> addLibDir + , preCopy = \_ _ -> addLibDir -- Not sure if necessary, but doesn't hurt. + , preInst = \_ _ -> addLibDir -- Not sure if necessary, but doesn't hurt. + , preReg = \_ _ -> addLibDir -- Necessary. + + , cleanHook = \pkgDesc z hooks flags -> do + cleanHook simpleUserHooks pkgDesc z hooks flags + let verbosity = fromFlagOrDefault normal $ cleanVerbosity flags + hsClean project verbosity + } + + where generatorProgram = getGeneratorProgram project + +hsCppLibDirFile :: FilePath +hsCppLibDirFile = "dist/build/hoppy-cpp-libdir" + +hsConfigure :: ProjectConfig -> Verbosity -> LocalBuildInfo -> Program -> IO () +hsConfigure project verbosity localBuildInfo generatorProgram = do + libDir <- lookupCppLibDir + storeCppLibDir libDir + generateSources + + where lookupCppLibDir = do + -- Look for an installed -cpp package. + let packageName = cppPackageName project + cppPkg <- case lookupPackageName (installedPkgs localBuildInfo) $ + PackageName packageName of + [(_, [pkg])] -> return pkg + results -> die $ "Failed to find a unique " ++ packageName ++ + " installation. Found " ++ show results ++ "." + + -- Look up the libdir of the package we found. The filter here is for NixOS, + -- where libraryDirs includes the library directories of dependencies as well. + case filter (\x -> packageName `isInfixOf` x) $ libraryDirs cppPkg of + [libDir] -> return libDir + libDirs -> die $ "Expected a single library directory for " ++ packageName ++ + ", got " ++ show libDirs ++ "." + + storeCppLibDir libDir = do + createDirectoryIfMissing True $ takeDirectory hsCppLibDirFile + writeFile hsCppLibDirFile libDir + + generateSources = do + let programDb = withPrograms localBuildInfo + sourcesDir = hsSourcesDir project + createDirectoryIfMissing True sourcesDir + runDbProgram verbosity generatorProgram programDb ["--gen-hs", sourcesDir] + +addLibDir :: IO HookedBuildInfo +addLibDir = do + libDir <- readFile hsCppLibDirFile + return (Just emptyBuildInfo {extraLibDirs = [libDir]}, []) + +hsClean :: ProjectConfig -> Verbosity -> IO () +hsClean = removeGeneratedFiles Haskell + +-- TODO Remove empty directories. +removeGeneratedFiles :: Language -> ProjectConfig -> Verbosity -> IO () +removeGeneratedFiles language project verbosity = do + let (listArg, sourcesDir) = case language of + Cpp -> ("--list-cpp-files", cppSourcesDir) + Haskell -> ("--list-hs-files", hsSourcesDir) + generatorProgram <- findSystemProgram verbosity $ generatorExecutableName project + generatedFiles <- fmap lines $ getProgramOutput verbosity generatorProgram [listArg] + forM_ generatedFiles $ \file -> do + let path = sourcesDir project file + exists <- doesFileExist path + when exists $ do + info verbosity $ "Removing " ++ path ++ "." + removeFile path