hoppy-generator 0.5.2 → 0.6.0

raw patch · 32 files changed

+8451/−5684 lines, 32 filesdep +bytestringdep +processdep +temporarydep ~containersdep ~mtlsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, process, temporary, text

Dependency ranges changed: containers, mtl

API changes (from Hackage documentation)

Files

• Setup.hs +1/−1
• hoppy-generator.cabal +22/−6
• src/Foreign/Hoppy/Generator/Common.hs +91/−18
• src/Foreign/Hoppy/Generator/Common/Consume.hs +30/−7
• src/Foreign/Hoppy/Generator/Compiler.hs +180/−0
• src/Foreign/Hoppy/Generator/Hook.hs +485/−0
• src/Foreign/Hoppy/Generator/Hook.hs-boot +25/−0
• src/Foreign/Hoppy/Generator/Language/Cpp.hs +240/−106
• src/Foreign/Hoppy/Generator/Language/Cpp.hs-boot +33/−0
• src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +12/−789
• src/Foreign/Hoppy/Generator/Language/Haskell.hs +96/−457
• src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot +17/−10
• src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +202/−1692
• src/Foreign/Hoppy/Generator/Main.hs +114/−30
• src/Foreign/Hoppy/Generator/Override.hs +187/−0
• src/Foreign/Hoppy/Generator/Spec.hs +11/−1
• src/Foreign/Hoppy/Generator/Spec/Base.hs +1831/−2513
• src/Foreign/Hoppy/Generator/Spec/Base.hs-boot +41/−0
• src/Foreign/Hoppy/Generator/Spec/Callback.hs +576/−0
• src/Foreign/Hoppy/Generator/Spec/Callback.hs-boot +27/−0
• src/Foreign/Hoppy/Generator/Spec/Class.hs +2116/−0
• src/Foreign/Hoppy/Generator/Spec/Class.hs-boot +72/−0
• src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +2/−1
• src/Foreign/Hoppy/Generator/Spec/Conversion.hs +17/−4
• src/Foreign/Hoppy/Generator/Spec/Enum.hs +524/−0
• src/Foreign/Hoppy/Generator/Spec/Enum.hs-boot +27/−0
• src/Foreign/Hoppy/Generator/Spec/Function.hs +905/−0
• src/Foreign/Hoppy/Generator/Spec/Function.hs-boot +29/−0
• src/Foreign/Hoppy/Generator/Spec/Variable.hs +123/−0
• src/Foreign/Hoppy/Generator/Types.hs +299/−48
• src/Foreign/Hoppy/Generator/Util.hs +115/−0
• src/Foreign/Hoppy/Generator/Version.hs +1/−1

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by

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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE CPP #-}+{-# 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

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

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

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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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 -- @\<type\> \<name\>@, where @\<name\>@ is the given name, and @\<type\>@ 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]

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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE CPP, 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<void*>(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<void(*)()>(f_));\n"-      say "        if (releaseRelease_) {\n"-      say "            release_(reinterpret_cast<void(*)()>(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<bool>(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])

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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+    -- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/separate_compilation.html#how-to-compile-mutually-recursive-modules GHC User's Guide>.+  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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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

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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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 <outdir>          Generate C++ bindings in a directory."     , "  --gen-hs <outdir>           Generate Haskell bindings under the given"     , "                              top-level source directory."+    , "  --keep-temp-outputs-on-failure"+    , "                              Keeps on disk any temporary programs that fail"+    , "                              to build.  Pass this before --gen-* commands."+    , "  --dump-ext-names            Lists the current interface's external names."+    , "  --dump-enums                Lists the current interface's enum data."+    , ""+    , "Arguments are processed in the order seen."     ]  processArgs :: MVar AppState -> [String] -> IO [Action]@@ -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

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

@@ -1,6 +1,6 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>+-- Copyright 2015-2019 Bryan Gardiner <bog@khumba.net> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -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

@@ -1,2518 +1,1836 @@ -- This file is part of Hoppy. ----- Copyright 2015-2018 Bryan Gardiner <bog@khumba.net>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program.  If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE CPP, 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 @<memory>@, but can be-    -- changed if necessary via 'interfaceSetSharedPtr'.-  }--instance Show Interface where-  show iface = concat ["<Interface ", show (interfaceName iface), ">"]---- | 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--- @\<T\>@ can be appended, for example @"std::shared_ptr"@.------ A @shared_ptr\<T\>@ 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 ["<Module ", moduleName 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' :: 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 ["<FnName ", show name, ">"]-  show (FnOp op) = concat ["<FnOp ", show op, ">"]---- | 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 $ "<Identifier " : words ++ [">"]) $-    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 ["<Variable ", show (varExtName v), " ", show (varType v), ">"]--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 ["<Enum ", show (enumExtName e), " ", show (enumIdentifier 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 }---- | 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 ["<Bitspace ", show (bitspaceExtName e), " ", show (bitspaceType e), ">"]--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 ["<Function ", show (fnExtName fn), " ", show (fnCName fn),-            show (fnParams fn), " ", show (fnReturn fn), ">"]--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 ["<Class ", show (classExtName cls), " ", show (classIdentifier cls), ">"]--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 ["<ClassVariable ",-            show $ classVarCName v, " ",-            show $ classVarExtName v, " ",-            show $ classVarStatic v, " ",-            show $ classVarType v, ">"]--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 ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]--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 ["<Method ", show (methodExtName method), " ",-            case methodImpl method of-              RealMethod name -> 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 ["<Callback ", show (callbackExtName cb), " ", show (callbackParams cb), " ",-            show (callbackReturn cb)]--instance HasExtNames Callback where-  getPrimaryExtName = callbackExtName--instance HasReqs Callback where-  getReqs = callbackReqs-  setReqs reqs cb = cb { callbackReqs = reqs }--instance HasAddendum Callback where-  getAddendum = callbackAddendum-  setAddendum addendum cb = cb { callbackAddendum = addendum }---- | Creates a binding for constructing callbacks into foreign code.-makeCallback :: ExtName-             -> [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 <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, 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 @\<memory\>@, 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 ["<Interface ", show (interfaceName iface), ">"]++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+-- @\<T\>@ can be appended, for example @"std::shared_ptr"@.+--+-- A @shared_ptr\<T\>@ 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 ["<Module ", moduleName m, ">"]++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 ["<FnName ", show name, ">"]+  show (FnOp op) = concat ["<FnOp ", show op, ">"]++-- | 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 $ "<Identifier " : wordList ++ [">"]) $+    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) = "<Export " ++ show 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 = "<ConversionSpec " ++ show (conversionSpecName 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\<std::string\>@.++  , 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 = "<EnumValueMap values=" ++ show (enumValueMapValues 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