-- This file is part of Hoppy.
--
-- Copyright 2015-2024 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/>.

-- | Interface for defining bindings to C++ enumerations.
--
-- In generated Haskell code:
--
-- An enum gets a single algebraic data type with data constructors for each of
-- the values defined in the interface.  If the enum has an unknown value name
-- defined, then an additional data constructor is generated that holds a
-- numeric value, and this constructor is used whenever numeric values for which
-- no name is explicitly defined are encountered (otherwise, 'error' is called).
--
-- From the runtime module, a @CppEnum@ instance is generated for the type, and
-- if the enum is declared to permit bit operations, then a 'Data.Bits.Bits'
-- instance is also generated.  'Eq' and 'Ord' instances are generated that
-- compare numeric values.
module Foreign.Hoppy.Generator.Spec.Enum (
  -- * Data type
  CppEnum, enumT,
  -- * Construction
  makeEnum, makeAutoEnum, IsAutoEnumValue (..),
  -- * Properties
  enumExtName,
  enumIdentifier,
  enumNumericType, enumSetNumericType,
  enumValues,
  enumReqs,
  enumAddendum,
  enumValuePrefix, enumSetValuePrefix,
  enumAddEntryNameOverrides,
  enumGetOverriddenEntryName,
  IsEnumUnknownValueEntry (..),
  enumUnknownValueEntry, enumSetUnknownValueEntry, enumSetNoUnknownValueEntry,
  enumUnknownValueEntryDefault,
  enumHasBitOperations, enumSetHasBitOperations,
  -- * C++ generator
  cppGetEvaluatedEnumData,
  -- * Haskell generator
  hsGetEvaluatedEnumData,
  -- ** Names
  toHsEnumTypeName, toHsEnumTypeName',
  toHsEnumCtorName, toHsEnumCtorName',
  ) where

import Control.Arrow ((&&&), (***))
import Control.Monad (forM, forM_, when)
import Control.Monad.Except (throwError)
import Data.Function (on)
import qualified Data.Map as M
import Foreign.Hoppy.Generator.Common (butLast, capitalize, for)
import Foreign.Hoppy.Generator.Spec.Base
import Foreign.Hoppy.Generator.Spec.Computed (
  EvaluatedEnumData,
  evaluatedEnumNumericType,
  evaluatedEnumValueMap,
  getEvaluatedEnumData,
  numType,
  )
import qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import Foreign.Hoppy.Generator.Override (addOverrideMap, overriddenMapLookup, plainMap)
import Foreign.Hoppy.Generator.Types (manualT)
import Foreign.Hoppy.Generator.Util (splitIntoWords)
import GHC.Stack (HasCallStack)
import Language.Haskell.Syntax (
  HsName (HsIdent),
  HsQName (UnQual),
  HsType (HsTyCon),
  )

-- | A C++ enum declaration.
--
-- See 'Foreign.Hoppy.Generator.Spec.EnumInfo'.
data CppEnum = CppEnum
  { CppEnum -> ExtName
enumExtName :: ExtName
    -- ^ The enum's external name.
  , CppEnum -> Identifier
enumIdentifier :: Identifier
    -- ^ The identifier used to refer to the enum.
  , CppEnum -> Maybe Type
enumNumericType :: Maybe Type
    -- ^ An optional, explicit numeric type provided for the enum's values, that
    -- matches what the C++ compiler uses.  Hoppy will use
    -- 'Foreign.Hoppy.Generator.Hook.Hooks' to compute this automatically, if
    -- not given manually.  This does not need to be provided.  If absent
    -- (default), then Hoppy will calculate the enum's numeric type on its own,
    -- using a C++ compiler.  If this is present however, Hoppy will use it, and
    -- additionally validate it against what the C++ compiler thinks, if
    -- validation is enabled (see 'interfaceValidateEnumTypes').
  , CppEnum -> Scoped
enumScoped :: Scoped
    -- ^ Whether the enum is scoped or unscoped.
  , CppEnum -> EnumValueMap
enumValues :: EnumValueMap
    -- ^ The numeric values and names of the enum entires.
  , CppEnum -> Reqs
enumReqs :: Reqs
    -- ^ Requirements for bindings to access this enum.  Currently unused, but
    -- will be in the future.
  , CppEnum -> Addendum
enumAddendum :: Addendum
    -- ^ The enum's addendum.
  , CppEnum -> ErrorMsg
enumValuePrefix :: String
    -- ^ The prefix applied to value names ('enumValues') when determining the
    -- names of values in foreign languages.  This defaults to the external name
    -- of the enum, plus an underscore.
    --
    -- See 'enumSetValuePrefix'.
  , CppEnum -> Maybe EnumEntryWords
enumUnknownValueEntry :: Maybe EnumEntryWords
    -- ^ A name (a list of words, a la the fields in 'EnumValueMap') for an
    -- optional fallback enum "entry" in generated bindings for holding unknown
    -- values.  See 'enumUnknownValueEntryDefault'.
    --
    -- When this is a @Just@, then the generated foreign binding gets an extra
    -- entry that takes an argument holding an arbitrary numeric value (an extra
    -- data constructor in Haskell), and this value is used whenever an unknown
    -- value is seen.
    --
    -- When this is @Nothing@, the enum will not support unknown values.
    -- @toCppEnum@ in the @Foreign.Hoppy.Runtime.CppEnum@ typeclass, as well as
    -- calls or returns from C++ that pass a value not defined in the interface,
    -- will raise an 'error'.
    --
    -- Enums that have this set to @Nothing@ should also have
    -- 'enumHasBitOperations' set to false, to avoid potential errors at
    -- runtime; see that function's documentation.
    --
    -- The 'enumValuePrefix' applies to this name, just as it does to other enum
    -- entries.
  , CppEnum -> Bool
enumHasBitOperations :: Bool
    -- ^ Whether generated bindings should support bitwise operations on the
    -- enum.  This defaults to true.
    --
    -- It is not recommended to disable the unknown value entry
    -- ('enumUnknownValueEntry') while having this be true, because any
    -- computation involving enum values not explicitly defined will cause a
    -- runtime error.  This includes undefined combinations of defined values.
  }

instance Eq CppEnum where
  == :: CppEnum -> CppEnum -> Bool
(==) = ExtName -> ExtName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ExtName -> ExtName -> Bool)
-> (CppEnum -> ExtName) -> CppEnum -> CppEnum -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CppEnum -> ExtName
enumExtName

instance Show CppEnum where
  show :: CppEnum -> ErrorMsg
show CppEnum
e = EnumEntryWords -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Enum ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (CppEnum -> ExtName
enumExtName CppEnum
e), ErrorMsg
" ", Identifier -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (CppEnum -> Identifier
enumIdentifier CppEnum
e), ErrorMsg
">"]

instance Exportable CppEnum where
  sayExportCpp :: SayExportMode -> CppEnum -> Generator ()
sayExportCpp SayExportMode
_ CppEnum
_ = () -> Generator ()
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Nothing to do for the C++ side of an enum.

  sayExportHaskell :: SayExportMode -> CppEnum -> Generator ()
sayExportHaskell = SayExportMode -> CppEnum -> Generator ()
sayHsExport

  getExportEnumInfo :: CppEnum -> Maybe EnumInfo
getExportEnumInfo CppEnum
e =
    EnumInfo -> Maybe EnumInfo
forall a. a -> Maybe a
Just EnumInfo
    { enumInfoExtName :: ExtName
enumInfoExtName = CppEnum -> ExtName
enumExtName CppEnum
e
    , enumInfoIdentifier :: Identifier
enumInfoIdentifier = CppEnum -> Identifier
enumIdentifier CppEnum
e
    , enumInfoNumericType :: Maybe Type
enumInfoNumericType = CppEnum -> Maybe Type
enumNumericType CppEnum
e
    , enumInfoReqs :: Reqs
enumInfoReqs = CppEnum -> Reqs
enumReqs CppEnum
e
    , enumInfoScoped :: Scoped
enumInfoScoped = CppEnum -> Scoped
enumScoped CppEnum
e
    , enumInfoValues :: EnumValueMap
enumInfoValues = CppEnum -> EnumValueMap
enumValues CppEnum
e
    }

instance HasExtNames CppEnum where
  getPrimaryExtName :: CppEnum -> ExtName
getPrimaryExtName = CppEnum -> ExtName
enumExtName

instance HasReqs CppEnum where
  getReqs :: CppEnum -> Reqs
getReqs = CppEnum -> Reqs
enumReqs
  setReqs :: Reqs -> CppEnum -> CppEnum
setReqs Reqs
reqs CppEnum
e = CppEnum
e { enumReqs = reqs }

instance HasAddendum CppEnum where
  getAddendum :: CppEnum -> Addendum
getAddendum = CppEnum -> Addendum
enumAddendum
  setAddendum :: Addendum -> CppEnum -> CppEnum
setAddendum Addendum
addendum CppEnum
e = CppEnum
e { enumAddendum = addendum }

-- | Sets an explicit numeric type for the enum.  See 'enumNumericType'.
enumSetNumericType :: Maybe Type -> CppEnum -> CppEnum
enumSetNumericType :: Maybe Type -> CppEnum -> CppEnum
enumSetNumericType Maybe Type
maybeType CppEnum
enum = CppEnum
enum { enumNumericType = maybeType }

-- | The default value for 'enumUnknownValueEntry'.  This is @[\"Unknown\"]@.
enumUnknownValueEntryDefault :: EnumEntryWords
enumUnknownValueEntryDefault :: EnumEntryWords
enumUnknownValueEntryDefault = [ErrorMsg
"Unknown"]

-- | Creates a binding for a C++ enum.
--
-- The numeric values of each of the enum's entries must be specified manually
-- using this function.  To have these determined automatically, instead use
-- 'makeAutoEnum'.
makeEnum ::
  Identifier  -- ^ 'enumIdentifier'
  -> Maybe ExtName
  -- ^ An optional external name; will be automatically derived from
  -- the identifier if absent.
  -> [(Integer, EnumEntryWords)]
  -- ^ A list of (numeric value, symbolic name) pairs describing enum entries to
  -- generate bindings for.  Each symbolic name is a list of words, which will
  -- be combined into a single identifier of appropriate naming style for the
  -- target language (title case, for Haskell) with 'enumValuePrefix' prepended.
  -> CppEnum
makeEnum :: Identifier
-> Maybe ExtName -> [(Integer, EnumEntryWords)] -> CppEnum
makeEnum Identifier
identifier Maybe ExtName
maybeExtName [(Integer, EnumEntryWords)]
entries =
  let extName :: ExtName
extName = HasCallStack => Identifier -> Maybe ExtName -> ExtName
Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier Identifier
identifier Maybe ExtName
maybeExtName
  in ExtName
-> Identifier
-> Maybe Type
-> Scoped
-> EnumValueMap
-> Reqs
-> Addendum
-> ErrorMsg
-> Maybe EnumEntryWords
-> Bool
-> CppEnum
CppEnum
     ExtName
extName
     Identifier
identifier
     Maybe Type
forall a. Maybe a
Nothing
     Scoped
Unscoped  -- Assume this is an unscoped enum.
     (let entries' :: [(EnumEntryWords, EnumValue)]
entries' = [(Integer, EnumEntryWords)]
-> ((Integer, EnumEntryWords) -> (EnumEntryWords, EnumValue))
-> [(EnumEntryWords, EnumValue)]
forall a b. [a] -> (a -> b) -> [b]
for [(Integer, EnumEntryWords)]
entries (((Integer, EnumEntryWords) -> (EnumEntryWords, EnumValue))
 -> [(EnumEntryWords, EnumValue)])
-> ((Integer, EnumEntryWords) -> (EnumEntryWords, EnumValue))
-> [(EnumEntryWords, EnumValue)]
forall a b. (a -> b) -> a -> b
$ \(Integer
num, EnumEntryWords
words') -> (EnumEntryWords
words', Integer -> EnumValue
EnumValueManual Integer
num)
          entryNames :: [EnumEntryWords]
entryNames = ((EnumEntryWords, EnumValue) -> EnumEntryWords)
-> [(EnumEntryWords, EnumValue)] -> [EnumEntryWords]
forall a b. (a -> b) -> [a] -> [b]
map (EnumEntryWords, EnumValue) -> EnumEntryWords
forall a b. (a, b) -> a
fst [(EnumEntryWords, EnumValue)]
entries'
      in EnumValueMap
         { enumValueMapNames :: [EnumEntryWords]
enumValueMapNames = [EnumEntryWords]
entryNames
         , enumValueMapForeignNames :: MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
enumValueMapForeignNames = Map EnumEntryWords EnumEntryWords
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
forall k v p. Map k v -> MapWithOverrides p k v
plainMap (Map EnumEntryWords EnumEntryWords
 -> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords)
-> Map EnumEntryWords EnumEntryWords
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EnumEntryWords, EnumEntryWords)]
 -> Map EnumEntryWords EnumEntryWords)
-> [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ (EnumEntryWords -> (EnumEntryWords, EnumEntryWords))
-> [EnumEntryWords] -> [(EnumEntryWords, EnumEntryWords)]
forall a b. (a -> b) -> [a] -> [b]
map (EnumEntryWords -> EnumEntryWords
forall a. a -> a
id (EnumEntryWords -> EnumEntryWords)
-> (EnumEntryWords -> EnumEntryWords)
-> EnumEntryWords
-> (EnumEntryWords, EnumEntryWords)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& EnumEntryWords -> EnumEntryWords
forall a. a -> a
id) [EnumEntryWords]
entryNames
         , enumValueMapValues :: Map EnumEntryWords EnumValue
enumValueMapValues = [(EnumEntryWords, EnumValue)] -> Map EnumEntryWords EnumValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EnumEntryWords, EnumValue)]
entries'
         })
     Reqs
forall a. Monoid a => a
mempty
     Addendum
forall a. Monoid a => a
mempty
     (ExtName -> ErrorMsg
fromExtName ExtName
extName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_")
     (EnumEntryWords -> Maybe EnumEntryWords
forall a. a -> Maybe a
Just EnumEntryWords
enumUnknownValueEntryDefault)
     Bool
True

-- | Creates a binding for a C++ enum.
--
-- An enum created using this function will determine its entries' numeric
-- values automatically when the generator is run, by compiling a temporary,
-- autogenerated C++ helper program.
--
-- This helper program needs to be able to access the C++ declaration of the
-- enum.  In addition to any 'includeStd' or 'includeLocal' requirements added
-- to the enum for the generated C++ bindings to use, the /interface's compiler/
-- ('interfaceCompiler') will need to be able to use these includes to access
-- the enum from C++ file built in a temporary directory.  To add @-I@ arguments
-- or otherwise change the compiler, you can reconfigure the interface:
--
-- @
-- myInterface =
--   'interfaceSetCompiler' (prependArguments [\"-I\" ++ pathToIncludes] defaultCompiler) $
--   'interface' ...
-- @
--
-- See "Foreign.Hoppy.Generator.Compiler".
makeAutoEnum ::
  IsAutoEnumValue v
  => Identifier  -- ^ 'enumIdentifier'
  -> Maybe ExtName
  -- ^ An optional external name; will be automatically derived from the
  -- identifier if absent.
  -> Scoped
  -- ^ Is the enum scoped (@enum class@ or @enum struct@)?  That is, are its
  -- entries scoped underneath its name, rather than being at the same level as
  -- its name (as with just @enum@).
  -> [v]
  -- ^ A list of enum entries to calculate and generate bindings for.  See
  -- 'IsAutoEnumValue'.
  -> CppEnum
makeAutoEnum :: forall v.
IsAutoEnumValue v =>
Identifier -> Maybe ExtName -> Scoped -> [v] -> CppEnum
makeAutoEnum Identifier
identifier Maybe ExtName
maybeExtName Scoped
scoped [v]
entries =
  let extName :: ExtName
extName = HasCallStack => Identifier -> Maybe ExtName -> ExtName
Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier Identifier
identifier Maybe ExtName
maybeExtName
  in ExtName
-> Identifier
-> Maybe Type
-> Scoped
-> EnumValueMap
-> Reqs
-> Addendum
-> ErrorMsg
-> Maybe EnumEntryWords
-> Bool
-> CppEnum
CppEnum
     ExtName
extName
     Identifier
identifier
     Maybe Type
forall a. Maybe a
Nothing
     Scoped
scoped
     (let namespaceForValues :: Identifier
namespaceForValues = case Scoped
scoped of
            Scoped
Scoped -> Identifier
identifier
            Scoped
Unscoped -> [IdPart] -> Identifier
makeIdentifier ([IdPart] -> Identifier) -> [IdPart] -> Identifier
forall a b. (a -> b) -> a -> b
$ [IdPart] -> [IdPart]
forall a. [a] -> [a]
butLast ([IdPart] -> [IdPart]) -> [IdPart] -> [IdPart]
forall a b. (a -> b) -> a -> b
$ Identifier -> [IdPart]
identifierParts Identifier
identifier
          entries' :: [(EnumEntryWords, Identifier)]
entries' =
            (v -> (EnumEntryWords, Identifier))
-> [v] -> [(EnumEntryWords, Identifier)]
forall a b. (a -> b) -> [a] -> [b]
map ((ErrorMsg -> Identifier)
-> (EnumEntryWords, ErrorMsg) -> (EnumEntryWords, Identifier)
forall a b. (a -> b) -> (EnumEntryWords, a) -> (EnumEntryWords, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ErrorMsg
name -> Identifier
namespaceForValues Identifier -> Identifier -> Identifier
forall a. Monoid a => a -> a -> a
`mappend` ErrorMsg -> Identifier
ident ErrorMsg
name) ((EnumEntryWords, ErrorMsg) -> (EnumEntryWords, Identifier))
-> (v -> (EnumEntryWords, ErrorMsg))
-> v
-> (EnumEntryWords, Identifier)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 v -> (EnumEntryWords, ErrorMsg)
forall a. IsAutoEnumValue a => a -> (EnumEntryWords, ErrorMsg)
toAutoEnumValue)
            [v]
entries
          entryNames :: [EnumEntryWords]
entryNames = ((EnumEntryWords, Identifier) -> EnumEntryWords)
-> [(EnumEntryWords, Identifier)] -> [EnumEntryWords]
forall a b. (a -> b) -> [a] -> [b]
map (EnumEntryWords, Identifier) -> EnumEntryWords
forall a b. (a, b) -> a
fst [(EnumEntryWords, Identifier)]
entries'
       in EnumValueMap
          { enumValueMapNames :: [EnumEntryWords]
enumValueMapNames = [EnumEntryWords]
entryNames
          , enumValueMapForeignNames :: MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
enumValueMapForeignNames = Map EnumEntryWords EnumEntryWords
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
forall k v p. Map k v -> MapWithOverrides p k v
plainMap (Map EnumEntryWords EnumEntryWords
 -> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords)
-> Map EnumEntryWords EnumEntryWords
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EnumEntryWords, EnumEntryWords)]
 -> Map EnumEntryWords EnumEntryWords)
-> [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ (EnumEntryWords -> (EnumEntryWords, EnumEntryWords))
-> [EnumEntryWords] -> [(EnumEntryWords, EnumEntryWords)]
forall a b. (a -> b) -> [a] -> [b]
map (EnumEntryWords -> EnumEntryWords
forall a. a -> a
id (EnumEntryWords -> EnumEntryWords)
-> (EnumEntryWords -> EnumEntryWords)
-> EnumEntryWords
-> (EnumEntryWords, EnumEntryWords)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& EnumEntryWords -> EnumEntryWords
forall a. a -> a
id) [EnumEntryWords]
entryNames
          , enumValueMapValues :: Map EnumEntryWords EnumValue
enumValueMapValues = (Identifier -> EnumValue)
-> Map EnumEntryWords Identifier -> Map EnumEntryWords EnumValue
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Identifier -> EnumValue
EnumValueAuto (Map EnumEntryWords Identifier -> Map EnumEntryWords EnumValue)
-> Map EnumEntryWords Identifier -> Map EnumEntryWords EnumValue
forall a b. (a -> b) -> a -> b
$ [(EnumEntryWords, Identifier)] -> Map EnumEntryWords Identifier
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EnumEntryWords, Identifier)]
entries'
          })
     Reqs
forall a. Monoid a => a
mempty
     Addendum
forall a. Monoid a => a
mempty
     (ExtName -> ErrorMsg
fromExtName ExtName
extName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_")
     (EnumEntryWords -> Maybe EnumEntryWords
forall a. a -> Maybe a
Just EnumEntryWords
enumUnknownValueEntryDefault)
     Bool
True

-- | Represents a mapping to an automatically evaluated C++ enum entry.
--
-- The @('EnumEntryWords', String)@ instance is the canonical one, with
-- 'toAutoEnumValue' defined as @id@.  The string on the right is the C++ name
-- of the entry, and the list of strings on the left are the words from which to
-- generate foreign bindings' entry names.
--
-- The @String@ instance takes the C++ name of the entry, and splits it into
-- words via 'splitIntoWords'.
class IsAutoEnumValue a where
  toAutoEnumValue :: a -> (EnumEntryWords, String)

instance IsAutoEnumValue (EnumEntryWords, String) where
  toAutoEnumValue :: (EnumEntryWords, ErrorMsg) -> (EnumEntryWords, ErrorMsg)
toAutoEnumValue = (EnumEntryWords, ErrorMsg) -> (EnumEntryWords, ErrorMsg)
forall a. a -> a
id

instance IsAutoEnumValue String where
  toAutoEnumValue :: ErrorMsg -> (EnumEntryWords, ErrorMsg)
toAutoEnumValue = ErrorMsg -> EnumEntryWords
splitIntoWords (ErrorMsg -> EnumEntryWords)
-> ShowS -> ErrorMsg -> (EnumEntryWords, ErrorMsg)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ShowS
forall a. a -> a
id

-- | Adds overrides for some of an enum's entry names, in a specific language.
enumAddEntryNameOverrides :: IsAutoEnumValue v => ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum
enumAddEntryNameOverrides :: forall v.
IsAutoEnumValue v =>
ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum
enumAddEntryNameOverrides ForeignLanguage
lang [(v, v)]
nameOverrides CppEnum
enum = CppEnum
enum { enumValues = enumValues' }
  where enumValues' :: EnumValueMap
enumValues' =
          (CppEnum -> EnumValueMap
enumValues CppEnum
enum)
          { enumValueMapForeignNames =
            addOverrideMap lang overrideMap $ enumValueMapForeignNames $ enumValues enum }
        overrideMap :: Map EnumEntryWords EnumEntryWords
overrideMap = [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EnumEntryWords, EnumEntryWords)]
 -> Map EnumEntryWords EnumEntryWords)
-> [(EnumEntryWords, EnumEntryWords)]
-> Map EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ ((v, v) -> (EnumEntryWords, EnumEntryWords))
-> [(v, v)] -> [(EnumEntryWords, EnumEntryWords)]
forall a b. (a -> b) -> [a] -> [b]
map (v -> EnumEntryWords
toEntryName (v -> EnumEntryWords)
-> (v -> EnumEntryWords)
-> (v, v)
-> (EnumEntryWords, EnumEntryWords)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** v -> EnumEntryWords
toEntryName) [(v, v)]
nameOverrides
        toEntryName :: v -> EnumEntryWords
toEntryName = (EnumEntryWords, ErrorMsg) -> EnumEntryWords
forall a b. (a, b) -> a
fst ((EnumEntryWords, ErrorMsg) -> EnumEntryWords)
-> (v -> (EnumEntryWords, ErrorMsg)) -> v -> EnumEntryWords
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> (EnumEntryWords, ErrorMsg)
forall a. IsAutoEnumValue a => a -> (EnumEntryWords, ErrorMsg)
toAutoEnumValue

-- | Retrieves the name for an enum entry in a specific foreign language.
enumGetOverriddenEntryName :: ForeignLanguage -> CppEnum -> EnumEntryWords -> EnumEntryWords
enumGetOverriddenEntryName :: ForeignLanguage -> CppEnum -> EnumEntryWords -> EnumEntryWords
enumGetOverriddenEntryName ForeignLanguage
lang CppEnum
enum EnumEntryWords
words' =
  case ForeignLanguage
-> EnumEntryWords
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
-> Maybe EnumEntryWords
forall p k v.
(Ord p, Ord k) =>
p -> k -> MapWithOverrides p k v -> Maybe v
overriddenMapLookup ForeignLanguage
lang EnumEntryWords
words' (MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
 -> Maybe EnumEntryWords)
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
-> Maybe EnumEntryWords
forall a b. (a -> b) -> a -> b
$ EnumValueMap
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
enumValueMapForeignNames (EnumValueMap
 -> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords)
-> EnumValueMap
-> MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
forall a b. (a -> b) -> a -> b
$ CppEnum -> EnumValueMap
enumValues CppEnum
enum of
    Just EnumEntryWords
words'' -> EnumEntryWords
words''
    Maybe EnumEntryWords
Nothing ->
      ErrorMsg -> EnumEntryWords
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> EnumEntryWords) -> ErrorMsg -> EnumEntryWords
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"enumGetOverriddenEntryName: Entry with name " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ EnumEntryWords -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show EnumEntryWords
words' ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++
      ErrorMsg
" not found in " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ CppEnum -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show CppEnum
enum ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"."

-- | Sets the prefix applied to the names of enum values' identifiers in foreign
-- languages.
--
-- See 'enumValuePrefix'.
enumSetValuePrefix :: String -> CppEnum -> CppEnum
enumSetValuePrefix :: ErrorMsg -> CppEnum -> CppEnum
enumSetValuePrefix ErrorMsg
prefix CppEnum
enum = CppEnum
enum { enumValuePrefix = prefix }

-- | Sets the entry name (a list of words, a la the fields in 'EnumValueMap')
-- for the fallback enum entry that holds unknown values.
--
-- Set 'enumUnknownValueEntry', 'enumSetNoUnknownValueEntry'.
enumSetUnknownValueEntry :: IsEnumUnknownValueEntry a => a -> CppEnum -> CppEnum
enumSetUnknownValueEntry :: forall a. IsEnumUnknownValueEntry a => a -> CppEnum -> CppEnum
enumSetUnknownValueEntry a
name CppEnum
enum =
  CppEnum
enum { enumUnknownValueEntry = Just $ toEnumUnknownValueEntry name }

-- | Sets an enum to have no unknown value entry.
--
-- Set 'enumUnknownValueEntry', 'enumSetUnknownValueEntry'.
enumSetNoUnknownValueEntry :: CppEnum -> CppEnum
enumSetNoUnknownValueEntry :: CppEnum -> CppEnum
enumSetNoUnknownValueEntry CppEnum
enum =
  CppEnum
enum { enumUnknownValueEntry = Nothing }

-- | Values that can be used as a name for an enum's unknown value entry.  See
-- 'enumUnknownValueEntry'.
class IsEnumUnknownValueEntry a where
  -- | Converts a value to a list of words to use for an enum's unknown entry
  -- name.
  toEnumUnknownValueEntry :: a -> EnumEntryWords

instance IsEnumUnknownValueEntry EnumEntryWords where
  toEnumUnknownValueEntry :: EnumEntryWords -> EnumEntryWords
toEnumUnknownValueEntry = EnumEntryWords -> EnumEntryWords
forall a. a -> a
id

instance IsEnumUnknownValueEntry String where
  toEnumUnknownValueEntry :: ErrorMsg -> EnumEntryWords
toEnumUnknownValueEntry = ErrorMsg -> EnumEntryWords
splitIntoWords

-- | Sets whether generated bindings will support bitwise operations on the
-- enum.
--
-- See 'enumHasBitOperations'.
enumSetHasBitOperations :: Bool -> CppEnum -> CppEnum
enumSetHasBitOperations :: Bool -> CppEnum -> CppEnum
enumSetHasBitOperations Bool
b CppEnum
enum = CppEnum
enum { enumHasBitOperations = b }

makeConversion :: CppEnum -> ConversionSpec
makeConversion :: CppEnum -> ConversionSpec
makeConversion CppEnum
e =
  (ErrorMsg -> ConversionSpecCpp -> ConversionSpec
makeConversionSpec (CppEnum -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show CppEnum
e) ConversionSpecCpp
cpp)
  { conversionSpecHaskell = Just hs }
  where cpp :: ConversionSpecCpp
cpp =
          ErrorMsg -> Generator Reqs -> ConversionSpecCpp
makeConversionSpecCpp (Identifier -> ErrorMsg
LC.renderIdentifier (Identifier -> ErrorMsg) -> Identifier -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ CppEnum -> Identifier
enumIdentifier CppEnum
e)
                                (Reqs -> Generator Reqs
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reqs -> Generator Reqs) -> Reqs -> Generator Reqs
forall a b. (a -> b) -> a -> b
$ CppEnum -> Reqs
enumReqs CppEnum
e)

        hs :: ConversionSpecHaskell
hs =
          Generator HsType
-> Maybe (Generator HsType)
-> ConversionMethod (Generator ())
-> ConversionMethod (Generator ())
-> ConversionSpecHaskell
makeConversionSpecHaskell
            (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (ErrorMsg -> HsQName) -> ErrorMsg -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> HsQName
UnQual (HsName -> HsQName) -> (ErrorMsg -> HsName) -> ErrorMsg -> HsQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> HsName
HsIdent (ErrorMsg -> HsType)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> Generator HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CppEnum -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumTypeName CppEnum
e)
            (Generator HsType -> Maybe (Generator HsType)
forall a. a -> Maybe a
Just (Generator HsType -> Maybe (Generator HsType))
-> Generator HsType -> Maybe (Generator HsType)
forall a b. (a -> b) -> a -> b
$ do EvaluatedEnumData
evaluatedData <- HasCallStack => ExtName -> Generator EvaluatedEnumData
ExtName -> Generator EvaluatedEnumData
hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
enumExtName CppEnum
e
                       HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
LH.HsCSide (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$
                         NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type) -> NumericTypeInfo -> Type
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType EvaluatedEnumData
evaluatedData)
            (Generator () -> ConversionMethod (Generator ())
forall c. c -> ConversionMethod c
CustomConversion (Generator () -> ConversionMethod (Generator ()))
-> Generator () -> ConversionMethod (Generator ())
forall a b. (a -> b) -> a -> b
$ do
               HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(.)",
                                        HsImportSet
hsImportForPrelude,
                                        HsImportSet
hsImportForRuntime]
               ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyP.return . HoppyFHR.fromCppEnum")
            (Generator () -> ConversionMethod (Generator ())
forall c. c -> ConversionMethod c
CustomConversion (Generator () -> ConversionMethod (Generator ()))
-> Generator () -> ConversionMethod (Generator ())
forall a b. (a -> b) -> a -> b
$ do
               HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(.)",
                                        HsImportSet
hsImportForPrelude,
                                        HsImportSet
hsImportForRuntime]
               ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyP.return . HoppyFHR.toCppEnum")

-- | Constructs a type value for an enum.
enumT :: CppEnum -> Type
-- (Keep docs in sync with hs-boot.)
enumT :: CppEnum -> Type
enumT = ConversionSpec -> Type
manualT (ConversionSpec -> Type)
-> (CppEnum -> ConversionSpec) -> CppEnum -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppEnum -> ConversionSpec
makeConversion

sayHsExport :: LH.SayExportMode -> CppEnum -> LH.Generator ()
sayHsExport :: SayExportMode -> CppEnum -> Generator ()
sayHsExport SayExportMode
mode CppEnum
enum =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating enum " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (CppEnum -> ExtName
enumExtName CppEnum
enum)) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  case SayExportMode
mode of
    -- Nothing to import from the C++ side of an enum.
    SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    SayExportMode
LH.SayExportDecls -> do
      ErrorMsg
hsTypeName <- CppEnum -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumTypeName CppEnum
enum
      EvaluatedEnumData
evaluatedData <- HasCallStack => ExtName -> Generator EvaluatedEnumData
ExtName -> Generator EvaluatedEnumData
hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
enumExtName CppEnum
enum
      HsType
numericType <- HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
LH.HsCSide (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$
        NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type) -> NumericTypeInfo -> Type
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType EvaluatedEnumData
evaluatedData
      let evaluatedValueMap :: EvaluatedEnumValueMap
evaluatedValueMap = EvaluatedEnumData -> EvaluatedEnumValueMap
evaluatedEnumValueMap EvaluatedEnumData
evaluatedData
      [(EnumEntryWords, Integer)]
evaluatedValues <- [EnumEntryWords]
-> (EnumEntryWords
    -> ReaderT
         Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer))
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) [(EnumEntryWords, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EnumValueMap -> [EnumEntryWords]
enumValueMapNames (EnumValueMap -> [EnumEntryWords])
-> EnumValueMap -> [EnumEntryWords]
forall a b. (a -> b) -> a -> b
$ CppEnum -> EnumValueMap
enumValues CppEnum
enum) ((EnumEntryWords
  -> ReaderT
       Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer))
 -> ReaderT
      Env (WriterT Output (Except ErrorMsg)) [(EnumEntryWords, Integer)])
-> (EnumEntryWords
    -> ReaderT
         Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer))
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) [(EnumEntryWords, Integer)]
forall a b. (a -> b) -> a -> b
$ \EnumEntryWords
name ->
        case EnumEntryWords -> EvaluatedEnumValueMap -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EnumEntryWords
name EvaluatedEnumValueMap
evaluatedValueMap of
          Just Integer
value -> (EnumEntryWords, Integer)
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer)
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumEntryWords
name, Integer
value)
          Maybe Integer
Nothing -> ErrorMsg
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer)
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg
 -> ReaderT
      Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer))
-> ErrorMsg
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) (EnumEntryWords, Integer)
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Couldn't find evaluated value for " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ EnumEntryWords -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show EnumEntryWords
name
      [(Integer, ErrorMsg)]
values :: [(Integer, String)] <- [(EnumEntryWords, Integer)]
-> ((EnumEntryWords, Integer)
    -> ReaderT
         Env (WriterT Output (Except ErrorMsg)) (Integer, ErrorMsg))
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) [(Integer, ErrorMsg)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(EnumEntryWords, Integer)]
evaluatedValues (((EnumEntryWords, Integer)
  -> ReaderT
       Env (WriterT Output (Except ErrorMsg)) (Integer, ErrorMsg))
 -> ReaderT
      Env (WriterT Output (Except ErrorMsg)) [(Integer, ErrorMsg)])
-> ((EnumEntryWords, Integer)
    -> ReaderT
         Env (WriterT Output (Except ErrorMsg)) (Integer, ErrorMsg))
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) [(Integer, ErrorMsg)]
forall a b. (a -> b) -> a -> b
$ \(EnumEntryWords
entryName, Integer
value) -> do
        let entryName' :: EnumEntryWords
entryName' = ForeignLanguage -> CppEnum -> EnumEntryWords -> EnumEntryWords
enumGetOverriddenEntryName ForeignLanguage
Haskell CppEnum
enum EnumEntryWords
entryName
        ErrorMsg
ctorName <- CppEnum
-> EnumEntryWords
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumCtorName CppEnum
enum EnumEntryWords
entryName'
        (Integer, ErrorMsg)
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) (Integer, ErrorMsg)
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
value, ErrorMsg
ctorName)
      Maybe ErrorMsg
maybeUnknownValueCtorName <- Maybe EnumEntryWords
-> (EnumEntryWords
    -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe ErrorMsg)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (CppEnum -> Maybe EnumEntryWords
enumUnknownValueEntry CppEnum
enum) ((EnumEntryWords
  -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe ErrorMsg))
-> (EnumEntryWords
    -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe ErrorMsg)
forall a b. (a -> b) -> a -> b
$ CppEnum
-> EnumEntryWords
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumCtorName CppEnum
enum
      HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(==)",
                               HsImportSet
hsImportForPrelude,
                               HsImportSet
hsImportForRuntime]

      -- Print out the data declaration.
      Generator ()
LH.ln
      ErrorMsg -> Generator ()
LH.addExport' ErrorMsg
hsTypeName
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"data ", ErrorMsg
hsTypeName, ErrorMsg
" ="]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [(Bool, (Integer, ErrorMsg))]
-> ((Bool, (Integer, ErrorMsg)) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Bool] -> [(Integer, ErrorMsg)] -> [(Bool, (Integer, ErrorMsg))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
FalseBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [(Integer, ErrorMsg)]
values) (((Bool, (Integer, ErrorMsg)) -> Generator ()) -> Generator ())
-> ((Bool, (Integer, ErrorMsg)) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Bool
cont, (Integer
_, ErrorMsg
hsCtorName)) ->
          EnumEntryWords -> Generator ()
LH.saysLn [if Bool
cont then ErrorMsg
"| " else ErrorMsg
"", ErrorMsg
hsCtorName]
        -- Only print an unknown value ctor if one has been requested.
        Maybe ErrorMsg -> (ErrorMsg -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ErrorMsg
maybeUnknownValueCtorName ((ErrorMsg -> Generator ()) -> Generator ())
-> (ErrorMsg -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \ErrorMsg
unknownValueCtorName ->
          EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"| ", ErrorMsg
unknownValueCtorName, ErrorMsg
" (", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
numericType, ErrorMsg
")"]
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"deriving (HoppyP.Show)"

      -- Print out the (runtime) CppEnum instance.
      Generator ()
LH.ln
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppEnum (", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
numericType, ErrorMsg
") ", ErrorMsg
hsTypeName,
                 ErrorMsg
" where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [(Integer, ErrorMsg)]
-> ((Integer, ErrorMsg) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Integer, ErrorMsg)]
values (((Integer, ErrorMsg) -> Generator ()) -> Generator ())
-> ((Integer, ErrorMsg) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Integer
num, ErrorMsg
hsCtorName) ->
          EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"fromCppEnum ", ErrorMsg
hsCtorName, ErrorMsg
" = ", Integer -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Integer
num]
        Maybe ErrorMsg -> (ErrorMsg -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ErrorMsg
maybeUnknownValueCtorName ((ErrorMsg -> Generator ()) -> Generator ())
-> (ErrorMsg -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \ErrorMsg
unknownValueCtorName ->
          EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"fromCppEnum (", ErrorMsg
unknownValueCtorName, ErrorMsg
" n) = n"]
        Generator ()
LH.ln
        -- We pass the values list through a map here to only keep the first
        -- constructor mapped to each numeric value, otherwise we'd write
        -- duplicate cases.
        [(Integer, ErrorMsg)]
-> ((Integer, ErrorMsg) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Integer ErrorMsg -> [(Integer, ErrorMsg)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Integer ErrorMsg -> [(Integer, ErrorMsg)])
-> Map Integer ErrorMsg -> [(Integer, ErrorMsg)]
forall a b. (a -> b) -> a -> b
$ (ErrorMsg -> ShowS)
-> [(Integer, ErrorMsg)] -> Map Integer ErrorMsg
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith ErrorMsg -> ShowS
forall a b. a -> b -> a
const [(Integer, ErrorMsg)]
values) (((Integer, ErrorMsg) -> Generator ()) -> Generator ())
-> ((Integer, ErrorMsg) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Integer
num, ErrorMsg
hsCtorName) ->
          EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"toCppEnum (", Integer -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Integer
num, ErrorMsg
") = ", ErrorMsg
hsCtorName]
        case Maybe ErrorMsg
maybeUnknownValueCtorName of
          Just ErrorMsg
unknownValueCtorName -> EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"toCppEnum n = ", ErrorMsg
unknownValueCtorName, ErrorMsg
" n"]
          Maybe ErrorMsg
Nothing -> do
            HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> EnumEntryWords -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"($)", ErrorMsg
"(++)"]
            EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"toCppEnum n' = HoppyP.error $ ",
                       ShowS
forall a. Show a => a -> ErrorMsg
show (EnumEntryWords -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"Unknown ", ErrorMsg
hsTypeName, ErrorMsg
" numeric value: "]),
                       ErrorMsg
" ++ HoppyP.show n'"]

      -- Print out Eq and Ord instances.
      Generator ()
LH.ln
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Eq ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"x == y = HoppyFHR.fromCppEnum x == HoppyFHR.fromCppEnum y"
      Generator ()
LH.ln
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Ord ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"compare x y = HoppyP.compare (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)"

      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CppEnum -> Bool
enumHasBitOperations CppEnum
enum) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> EnumEntryWords -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"($)", ErrorMsg
"(.)"],
                                 ErrorMsg -> EnumEntryWords -> HsImportSet
hsImports ErrorMsg
"Data.Bits" [ErrorMsg
"(.&.)", ErrorMsg
"(.|.)"],
                                 HsImportSet
hsImportForBits]
        EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyDB.Bits ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          let fun1 :: ErrorMsg -> Generator ()
fun1 ErrorMsg
f =
                EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
f, ErrorMsg
" x = HoppyFHR.toCppEnum $ HoppyDB.",
                           ErrorMsg
f, ErrorMsg
" $ HoppyFHR.fromCppEnum x"]
              fun1Int :: ErrorMsg -> Generator ()
fun1Int ErrorMsg
f =
                EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
f, ErrorMsg
" x i = HoppyFHR.toCppEnum $ HoppyDB.",
                           ErrorMsg
f, ErrorMsg
" (HoppyFHR.fromCppEnum x) i"]
              fun2 :: ErrorMsg -> Generator ()
fun2 ErrorMsg
f =
                EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
f, ErrorMsg
" x y = HoppyFHR.toCppEnum $ HoppyDB.",
                           ErrorMsg
f, ErrorMsg
" (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)"]
              op2 :: ErrorMsg -> Generator ()
op2 ErrorMsg
op =
                EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"x ", ErrorMsg
op, ErrorMsg
" y = HoppyFHR.toCppEnum ",
                           ErrorMsg
"(HoppyFHR.fromCppEnum x ", ErrorMsg
op, ErrorMsg
" HoppyFHR.fromCppEnum y)"]
          ErrorMsg -> Generator ()
op2 ErrorMsg
".&."
          ErrorMsg -> Generator ()
op2 ErrorMsg
".|."
          ErrorMsg -> Generator ()
fun2 ErrorMsg
"xor"
          ErrorMsg -> Generator ()
fun1 ErrorMsg
"complement"
          ErrorMsg -> Generator ()
fun1Int ErrorMsg
"shift"
          ErrorMsg -> Generator ()
fun1Int ErrorMsg
"rotate"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"bitSize x = case HoppyDB.bitSizeMaybe x of"
          Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
            ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"  HoppyP.Just n -> n"
            -- Same error message as the prelude here:
            ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"  HoppyP.Nothing -> HoppyP.error \"bitSize is undefined\""
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"bitSizeMaybe = HoppyDB.bitSizeMaybe . HoppyFHR.fromCppEnum"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"isSigned = HoppyDB.isSigned . HoppyFHR.fromCppEnum"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"testBit x i = HoppyDB.testBit (HoppyFHR.fromCppEnum x) i"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"bit = HoppyFHR.toCppEnum . HoppyDB.bit"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"popCount = HoppyDB.popCount . HoppyFHR.fromCppEnum"

    SayExportMode
LH.SayExportBoot -> do
      ErrorMsg
hsTypeName <- CppEnum -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumTypeName CppEnum
enum
      EvaluatedEnumData
evaluatedData <- HasCallStack => ExtName -> Generator EvaluatedEnumData
ExtName -> Generator EvaluatedEnumData
hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
enumExtName CppEnum
enum
      HsType
numericType <- HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
LH.HsCSide (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$
        NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type) -> NumericTypeInfo -> Type
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType EvaluatedEnumData
evaluatedData
      HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
      ErrorMsg -> Generator ()
LH.addExport ErrorMsg
hsTypeName
      Generator ()
LH.ln
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"data ", ErrorMsg
hsTypeName]
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppEnum (", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
numericType, ErrorMsg
") ", ErrorMsg
hsTypeName]
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Eq ", ErrorMsg
hsTypeName]
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Ord ", ErrorMsg
hsTypeName]
      EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Show ", ErrorMsg
hsTypeName]
      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CppEnum -> Bool
enumHasBitOperations CppEnum
enum) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForBits
        EnumEntryWords -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyDB.Bits ", ErrorMsg
hsTypeName]

-- | Reads evaluated data for the named enum from the C++ generator environment.
cppGetEvaluatedEnumData :: HasCallStack => ExtName -> LC.Generator EvaluatedEnumData
cppGetEvaluatedEnumData :: HasCallStack => ExtName -> Generator EvaluatedEnumData
cppGetEvaluatedEnumData ExtName
extName = do
  ComputedInterfaceData
computed <- Generator ComputedInterfaceData
LC.askComputedInterfaceData
  EvaluatedEnumData -> Generator EvaluatedEnumData
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvaluatedEnumData -> Generator EvaluatedEnumData)
-> EvaluatedEnumData -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ComputedInterfaceData -> ExtName -> EvaluatedEnumData
ComputedInterfaceData -> ExtName -> EvaluatedEnumData
getEvaluatedEnumData ComputedInterfaceData
computed ExtName
extName

-- | Reads evaluated data for the named enum from the Haskell generator
-- environment.
hsGetEvaluatedEnumData :: HasCallStack => ExtName -> LH.Generator EvaluatedEnumData
hsGetEvaluatedEnumData :: HasCallStack => ExtName -> Generator EvaluatedEnumData
hsGetEvaluatedEnumData ExtName
extName = do
  ComputedInterfaceData
computed <- Generator ComputedInterfaceData
LH.askComputedInterfaceData
  EvaluatedEnumData -> Generator EvaluatedEnumData
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvaluatedEnumData -> Generator EvaluatedEnumData)
-> EvaluatedEnumData -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ComputedInterfaceData -> ExtName -> EvaluatedEnumData
ComputedInterfaceData -> ExtName -> EvaluatedEnumData
getEvaluatedEnumData ComputedInterfaceData
computed ExtName
extName

-- | Returns the Haskell name for an enum.
--
-- TODO Clarify, and split into type and data ctor names.
toHsEnumTypeName :: CppEnum -> LH.Generator String
toHsEnumTypeName :: CppEnum -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumTypeName CppEnum
enum =
  ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsEnumTypeName" (ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
LH.addExtNameModule (CppEnum -> ExtName
enumExtName CppEnum
enum) (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$ CppEnum -> ErrorMsg
toHsEnumTypeName' CppEnum
enum

-- | Pure version of 'toHsEnumTypeName' that doesn't create a qualified name.
toHsEnumTypeName' :: CppEnum -> String
toHsEnumTypeName' :: CppEnum -> ErrorMsg
toHsEnumTypeName' = Constness -> ExtName -> ErrorMsg
LH.toHsTypeName' Constness
Nonconst (ExtName -> ErrorMsg)
-> (CppEnum -> ExtName) -> CppEnum -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppEnum -> ExtName
enumExtName

-- | Constructs the data constructor name for a value in an enum.  Like C++ and
-- unlike say Java, Haskell enum values aren't in a separate enum-specific
-- namespace, so we prepend the enum name to the value name to get the data
-- constructor name.  The value name is a list of words.
toHsEnumCtorName :: CppEnum -> EnumEntryWords -> LH.Generator String
toHsEnumCtorName :: CppEnum
-> EnumEntryWords
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsEnumCtorName CppEnum
enum EnumEntryWords
words' =
  ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsEnumCtorName" (ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
LH.addExtNameModule (CppEnum -> ExtName
enumExtName CppEnum
enum) (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$ CppEnum -> EnumEntryWords -> ErrorMsg
toHsEnumCtorName' CppEnum
enum EnumEntryWords
words'

-- | Pure version of 'toHsEnumCtorName' that doesn't create a qualified name.
toHsEnumCtorName' :: CppEnum -> EnumEntryWords -> String
toHsEnumCtorName' :: CppEnum -> EnumEntryWords -> ErrorMsg
toHsEnumCtorName' CppEnum
enum EnumEntryWords
words' =
  EnumEntryWords -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (EnumEntryWords -> ErrorMsg) -> EnumEntryWords -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ CppEnum -> ErrorMsg
enumValuePrefix CppEnum
enum ErrorMsg -> EnumEntryWords -> EnumEntryWords
forall a. a -> [a] -> [a]
: ShowS -> EnumEntryWords -> EnumEntryWords
forall a b. (a -> b) -> [a] -> [b]
map ShowS
capitalize EnumEntryWords
words'