hoppy-runtime 0.3.0 → 0.3.1

raw patch · 4 files changed

+409/−33 lines, 4 filesdep +Cabaldep +directorydep +filepathsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, directory, filepath

API changes (from Hackage documentation)

Files

• Setup.hs +1/−1
• hoppy-runtime.cabal +6/−2
• src/Foreign/Hoppy/Runtime.hs +33/−30
• src/Foreign/Hoppy/Setup.hs +369/−0

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2016 Bryan Gardiner <bog@khumba.net>+-- Copyright 2016-2017 Bryan Gardiner <bog@khumba.net> -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -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 <bog@khumba.net> maintainer: Bryan Gardiner <bog@khumba.net>-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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2017 Bryan Gardiner <bog@khumba.net> -- -- 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 = "<Unhandled C++ exception>"+    , exceptionClassName = "<Unknown C++ exception>"     , exceptionClassUpcasts = M.empty     , exceptionClassDelete = error "UnknownCppException.exceptionClassDelete: Should not get here."     , exceptionClassCopy = error "UnknownCppException.exceptionClassCopy: Should not get here."

@@ -0,0 +1,369 @@+-- This file is part of Hoppy.+--+-- Copyright 2017 Bryan Gardiner <bog@khumba.net>+--+-- 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