-- This file is part of Qtah.
--
-- Copyright 2015-2021 The Qtah Authors.
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Lesser 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 Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Graphics.UI.Qtah.Generator.Flags (
  -- * Data type
  Flags, flagsT,
  -- * Construction
  makeFlags,
  -- * Properties
  flagsExtName,
  flagsIdentifier,
  flagsEnum,
  flagsReqs,
  flagsAddendum,
  -- * Haskell generator
  -- ** Names
  toHsFlagsTypeName',
  toHsFlagsTypeclassName',
  toHsFlagsBindingName,
  toHsFlagsBindingName',
  ) where

import Control.Monad (forM_, when)
import Control.Monad.Except (throwError)
import qualified Data.Map as M
import qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import Foreign.Hoppy.Generator.Spec (
  Addendum,
  Constness (Nonconst),
  ConversionMethod (CustomConversion),
  ConversionSpec,
  Exportable,
  ExtName,
  ForeignLanguage (Haskell),
  HasAddendum,
  HasExtNames,
  HasReqs,
  Identifier,
  Reqs,
  Type,
  conversionSpecCppConversionFromCppExpr,
  conversionSpecCppConversionToCppExpr,
  conversionSpecCppConversionType,
  conversionSpecHaskell,
  conversionSpecHaskellHsArgType,
  evaluatedEnumNumericType,
  evaluatedEnumValueMap,
  getAddendum,
  getPrimaryExtName,
  getReqs,
  hsImport1,
  hsImports,
  identifierParts,
  idPartBase,
  makeConversionSpec,
  makeConversionSpecCpp,
  makeConversionSpecHaskell,
  makeIdentifier,
  makeIdPart,
  modifyAddendum,
  modifyReqs,
  numType,
  sayExportCpp,
  sayExportHaskell,
  setAddendum,
  setReqs,
  toExtName,
  )
import qualified Foreign.Hoppy.Generator.Spec.Enum as Enum
import Foreign.Hoppy.Generator.Types (manualT)
import Graphics.UI.Qtah.Generator.Common (lowerFirst, replaceLast)
import Graphics.UI.Qtah.Generator.Interface.Imports (
  importForBits,
  importForFlags,
  importForPrelude,
  importForRuntime,
  )
import Language.Haskell.Syntax (
  HsName (HsIdent),
  HsQName (UnQual),
  HsQualType (HsQualType),
  HsType (HsTyCon, HsTyVar),
  )

-- | This is an exportable wrapper around a 'Enum.CppEnum' that also generates
-- support for a @QFlags\<Enum\>@ typedef.
--
-- This does not export any ExtNames of its own.
--
-- In generated Haskell code, in addition to what is generated for the
-- 'Enum.CppEnum', we generate a newtype wrapper around an enum value to
-- represent a combination of flags, and an @IsXXX@ typeclass for converting
-- various types (flags type, enum type, raw number) to a newtype'd value.
data Flags = Flags
  { Flags -> ExtName
flagsExtName :: ExtName
  , Flags -> Identifier
flagsIdentifier :: Identifier
  , Flags -> CppEnum
flagsEnum :: Enum.CppEnum
  , Flags -> Reqs
flagsReqs :: Reqs
  , Flags -> Addendum
flagsAddendum :: Addendum
  }

instance Show Flags where
  show :: Flags -> String
show Flags
flags =
    String
"<Flags " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    ExtName -> String
forall a. Show a => a -> String
show (Flags -> ExtName
flagsExtName Flags
flags) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    Identifier -> String
LC.renderIdentifier (Flags -> Identifier
flagsIdentifier Flags
flags) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"

instance HasAddendum Flags where
  getAddendum :: Flags -> Addendum
getAddendum = Flags -> Addendum
flagsAddendum
  setAddendum :: Addendum -> Flags -> Flags
setAddendum Addendum
a Flags
flags = Flags
flags { flagsAddendum :: Addendum
flagsAddendum = Addendum
a }
  modifyAddendum :: (Addendum -> Addendum) -> Flags -> Flags
modifyAddendum Addendum -> Addendum
f Flags
flags = Flags
flags { flagsAddendum :: Addendum
flagsAddendum = Addendum -> Addendum
f (Addendum -> Addendum) -> Addendum -> Addendum
forall a b. (a -> b) -> a -> b
$ Flags -> Addendum
flagsAddendum Flags
flags }

instance HasExtNames Flags where
  getPrimaryExtName :: Flags -> ExtName
getPrimaryExtName = Flags -> ExtName
flagsExtName

instance HasReqs Flags where
  getReqs :: Flags -> Reqs
getReqs = Flags -> Reqs
flagsReqs
  setReqs :: Reqs -> Flags -> Flags
setReqs Reqs
r Flags
flags = Flags
flags { flagsReqs :: Reqs
flagsReqs = Reqs
r }
  modifyReqs :: (Reqs -> Reqs) -> Flags -> Flags
modifyReqs Reqs -> Reqs
f Flags
flags = Flags
flags { flagsReqs :: Reqs
flagsReqs = Reqs -> Reqs
f (Reqs -> Reqs) -> Reqs -> Reqs
forall a b. (a -> b) -> a -> b
$ Flags -> Reqs
flagsReqs Flags
flags }

instance Exportable Flags where
  -- Nothing to generate for flags here.  (Enums don't have any generated C++
  -- code here either.)
  sayExportCpp :: SayExportMode -> Flags -> Generator ()
sayExportCpp SayExportMode
_ Flags
_ = () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  sayExportHaskell :: SayExportMode -> Flags -> Generator ()
sayExportHaskell SayExportMode
mode Flags
flags = SayExportMode -> Flags -> Generator ()
sayHsExport SayExportMode
mode Flags
flags

makeFlags :: Enum.CppEnum -> String -> Flags
makeFlags :: CppEnum -> String -> Flags
makeFlags CppEnum
enum String
flagsName =
  let identifierWords :: [String]
identifierWords =
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
replaceLast String
flagsName ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (IdPart -> String) -> [IdPart] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IdPart -> String
idPartBase ([IdPart] -> [String]) -> [IdPart] -> [String]
forall a b. (a -> b) -> a -> b
$ Identifier -> [IdPart]
identifierParts (Identifier -> [IdPart]) -> Identifier -> [IdPart]
forall a b. (a -> b) -> a -> b
$ CppEnum -> Identifier
Enum.enumIdentifier CppEnum
enum
      identifier :: Identifier
identifier = [IdPart] -> Identifier
makeIdentifier ([IdPart] -> Identifier) -> [IdPart] -> Identifier
forall a b. (a -> b) -> a -> b
$ (String -> IdPart) -> [String] -> [IdPart]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> String -> Maybe [Type] -> IdPart
makeIdPart String
s Maybe [Type]
forall a. Maybe a
Nothing) [String]
identifierWords
  in Flags :: ExtName -> Identifier -> CppEnum -> Reqs -> Addendum -> Flags
Flags
     { flagsExtName :: ExtName
flagsExtName = HasCallStack => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
identifierWords
     , flagsIdentifier :: Identifier
flagsIdentifier = Identifier
identifier
     , flagsEnum :: CppEnum
flagsEnum = CppEnum
enum
     , flagsReqs :: Reqs
flagsReqs = CppEnum -> Reqs
Enum.enumReqs CppEnum
enum  -- Copy reqs from the underlying enum.
     , flagsAddendum :: Addendum
flagsAddendum = Addendum
forall a. Monoid a => a
mempty
     }

flagsT :: Flags -> Type
flagsT :: Flags -> Type
flagsT = ConversionSpec -> Type
manualT (ConversionSpec -> Type)
-> (Flags -> ConversionSpec) -> Flags -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flags -> ConversionSpec
makeConversion

makeConversion :: Flags -> ConversionSpec
makeConversion :: Flags -> ConversionSpec
makeConversion Flags
flags =
  (String -> ConversionSpecCpp -> ConversionSpec
makeConversionSpec (Flags -> String
forall a. Show a => a -> String
show Flags
flags) ConversionSpecCpp
cpp)
  { conversionSpecHaskell :: Maybe ConversionSpecHaskell
conversionSpecHaskell = ConversionSpecHaskell -> Maybe ConversionSpecHaskell
forall a. a -> Maybe a
Just ConversionSpecHaskell
hs }
  where extName :: ExtName
extName = Flags -> ExtName
flagsExtName Flags
flags
        identifier :: Identifier
identifier = Flags -> Identifier
flagsIdentifier Flags
flags
        identifierStr :: String
identifierStr = Identifier -> String
LC.renderIdentifier Identifier
identifier
        enum :: CppEnum
enum = Flags -> CppEnum
flagsEnum Flags
flags

        cpp :: ConversionSpecCpp
cpp =
          (String -> Generator Reqs -> ConversionSpecCpp
makeConversionSpecCpp String
identifierStr (Reqs -> Generator Reqs
forall (m :: * -> *) a. Monad m => a -> m a
return (Reqs -> Generator Reqs) -> Reqs -> Generator Reqs
forall a b. (a -> b) -> a -> b
$ CppEnum -> Reqs
Enum.enumReqs CppEnum
enum))
          { conversionSpecCppConversionType :: Generator (Maybe Type)
conversionSpecCppConversionType =
              Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type)
-> (EvaluatedEnumData -> Type) -> EvaluatedEnumData -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type)
-> (EvaluatedEnumData -> NumericTypeInfo)
-> EvaluatedEnumData
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType (EvaluatedEnumData -> Maybe Type)
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
-> Generator (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              HasCallStack =>
ExtName
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
ExtName
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
Enum.cppGetEvaluatedEnumData (CppEnum -> ExtName
Enum.enumExtName CppEnum
enum)

          , conversionSpecCppConversionToCppExpr :: Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionToCppExpr = (Generator () -> Maybe (Generator ()) -> Generator ())
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a. a -> Maybe a
Just ((Generator () -> Maybe (Generator ()) -> Generator ())
 -> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> (Generator () -> Maybe (Generator ()) -> Generator ())
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$ \Generator ()
fromVar Maybe (Generator ())
maybeToVar -> case Maybe (Generator ())
maybeToVar of
              Just Generator ()
toVar ->
                [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
identifierStr, String
" "] Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
toVar Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"(" Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
fromVar Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
");\n"
              Maybe (Generator ())
Nothing -> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
identifierStr, String
"("] Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
fromVar Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
")"

          , conversionSpecCppConversionFromCppExpr :: Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionFromCppExpr = (Generator () -> Maybe (Generator ()) -> Generator ())
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a. a -> Maybe a
Just ((Generator () -> Maybe (Generator ()) -> Generator ())
 -> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> (Generator () -> Maybe (Generator ()) -> Generator ())
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$ \Generator ()
fromVar Maybe (Generator ())
maybeToVar -> do
              Type
t <-
                NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type)
-> (EvaluatedEnumData -> NumericTypeInfo)
-> EvaluatedEnumData
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType (EvaluatedEnumData -> Type)
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
-> ReaderT Env (WriterT [Chunk] (Either String)) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                HasCallStack =>
ExtName
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
ExtName
-> ReaderT Env (WriterT [Chunk] (Either String)) EvaluatedEnumData
Enum.cppGetEvaluatedEnumData (CppEnum -> ExtName
Enum.enumExtName CppEnum
enum)
              Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Generator ())
maybeToVar ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
toVar -> do
                Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [String] -> Type -> m ()
LC.sayType Maybe [String]
forall a. Maybe a
Nothing Type
t
                String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
" "
                Generator ()
toVar
                String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
" = "
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"static_cast<"
              Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [String] -> Type -> m ()
LC.sayType Maybe [String]
forall a. Maybe a
Nothing Type
t
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
">("
              Generator ()
fromVar
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ case Maybe (Generator ())
maybeToVar of
                Just Generator ()
_ -> String
");\n"
                Maybe (Generator ())
Nothing -> String
")"
          }

        hs :: ConversionSpecHaskell
hs =
          (Generator HsType
-> Maybe (Generator HsType)
-> ConversionMethod (Generator ())
-> ConversionMethod (Generator ())
-> ConversionSpecHaskell
makeConversionSpecHaskell
             (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> HsQName
UnQual (HsName -> HsQName) -> (String -> HsName) -> String -> HsQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent (String -> HsType)
-> ReaderT Env (WriterT Output (Except String)) String
-> Generator HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Constness
-> ExtName -> ReaderT Env (WriterT Output (Except String)) String
LH.toHsTypeName Constness
Nonconst ExtName
extName)
             (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
Enum.hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
Enum.enumExtName CppEnum
enum
                        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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(.)",
                                         HsImportSet
importForFlags,
                                         HsImportSet
importForPrelude]
                String
convertFn <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsConvertFnName Flags
flags
                [String] -> Generator ()
LH.saysLn [String
"QtahP.return . QtahFlags.flagsToNum . ", String
convertFn])
             (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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(.)",
                                         HsImportSet
importForFlags,
                                         HsImportSet
importForPrelude]
                String -> Generator ()
LH.sayLn String
"QtahP.return . QtahFlags.numToFlags"))
          { conversionSpecHaskellHsArgType :: Maybe (HsName -> Generator HsQualType)
conversionSpecHaskellHsArgType = (HsName -> Generator HsQualType)
-> Maybe (HsName -> Generator HsQualType)
forall a. a -> Maybe a
Just ((HsName -> Generator HsQualType)
 -> Maybe (HsName -> Generator HsQualType))
-> (HsName -> Generator HsQualType)
-> Maybe (HsName -> Generator HsQualType)
forall a b. (a -> b) -> a -> b
$ \HsName
typeVar -> do
              String
typeclassName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeclassName Flags
flags
              HsQualType -> Generator HsQualType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType -> Generator HsQualType)
-> HsQualType -> Generator HsQualType
forall a b. (a -> b) -> a -> b
$
                HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
typeclassName, [HsName -> HsType
HsTyVar HsName
typeVar])] (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$
                HsName -> HsType
HsTyVar HsName
typeVar
          }

sayHsExport :: LH.SayExportMode -> Flags -> LH.Generator ()
sayHsExport :: SayExportMode -> Flags -> Generator ()
sayHsExport SayExportMode
mode Flags
flags =
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Flags -> String
forall a. Show a => a -> String
show Flags
flags) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do

  -- Ensure that the flags is exported from the same module as its underlying
  -- enum.  We always want this to be the case.
  Generator ()
checkInFlagsEnumModule

  case SayExportMode
mode of
    SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    SayExportMode
LH.SayExportDecls -> do
      String
typeName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeName Flags
flags
      String
typeclassName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeclassName Flags
flags
      String
convertFnName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsConvertFnName Flags
flags
      -- We'll use the type name as the data constructor name as well:
      let ctorName :: String
ctorName = String
typeName
          enum :: CppEnum
enum = Flags -> CppEnum
flagsEnum Flags
flags
      String
enumTypeName <- CppEnum -> ReaderT Env (WriterT Output (Except String)) String
Enum.toHsEnumTypeName CppEnum
enum
      EvaluatedEnumData
enumData <- HasCallStack => ExtName -> Generator EvaluatedEnumData
ExtName -> Generator EvaluatedEnumData
Enum.hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
Enum.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
enumData
      let numericTypeStr :: String
numericTypeStr = HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
numericType

      -- Emit the newtype wrapper.
      String -> Generator ()
LH.addExport String
typeName
      HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"($)", String
"(.)"],
                               String -> [String] -> HsImportSet
hsImports String
"Data.Bits" [String
"(.&.)", String
"(.|.)"],
                               HsImportSet
importForBits,
                               HsImportSet
importForFlags,
                               HsImportSet
importForPrelude,
                               HsImportSet
importForRuntime]
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"newtype ", String
typeName, String
" = ", String
ctorName, String
" (", String
numericTypeStr,
                 String
") deriving (QtahP.Eq, QtahP.Ord, QtahP.Show)"]

      -- Emit the Flags instance.
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance QtahFlags.Flags (", String
numericTypeStr, String
") ",
                 String
enumTypeName, String
" ", String
typeName, String
" where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [String] -> Generator ()
LH.saysLn [String
"enumToFlags = ", String
ctorName, String
" . QtahFHR.fromCppEnum"]
        [String] -> Generator ()
LH.saysLn [String
"flagsToEnum (", String
ctorName, String
" x') = QtahFHR.toCppEnum x'"]

      -- Emit an IsXXX typeclass with a method to convert arguments to flag
      -- values.
      String -> Generator ()
LH.addExport' String
typeclassName
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"class ", String
typeclassName, String
" a where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [String] -> Generator ()
LH.saysLn [String
convertFnName, String
" :: a -> ", String
typeName]

      -- Emit IsXXX instances for the flags, enum, and numeric types.
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" ", String
typeName,
                 String
" where ", String
convertFnName, String
" = QtahP.id"]
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" ", String
enumTypeName,
                 String
" where ", String
convertFnName, String
" = QtahFlags.enumToFlags"]
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" (", String
numericTypeStr,
                 String
") where ", String
convertFnName, String
" = QtahFlags.numToFlags"]

      -- Emit Haskell bindings for flags entries.
      [([String], Integer)]
-> (([String], Integer) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map [String] Integer -> [([String], Integer)]
forall k a. Map k a -> [(k, a)]
M.toList (Map [String] Integer -> [([String], Integer)])
-> Map [String] Integer -> [([String], Integer)]
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> Map [String] Integer
evaluatedEnumValueMap EvaluatedEnumData
enumData) ((([String], Integer) -> Generator ()) -> Generator ())
-> (([String], Integer) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \([String]
words, Integer
num) -> do
        let words' :: [String]
words' = ForeignLanguage -> CppEnum -> [String] -> [String]
Enum.enumGetOverriddenEntryName ForeignLanguage
Haskell CppEnum
enum [String]
words
        String
bindingName <- Flags
-> [String] -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsBindingName Flags
flags [String]
words'
        String -> Generator ()
LH.addExport String
bindingName
        Generator ()
LH.ln
        [String] -> Generator ()
LH.saysLn [String
bindingName, String
" :: ", String
typeName]
        [String] -> Generator ()
LH.saysLn [String
bindingName, String
" = ", String
ctorName, String
" (", Integer -> String
forall a. Show a => a -> String
show Integer
num, String
")"]

      -- Emit the Bits instance.  This code is the same as what Hoppy uses to
      -- emit enum Bits instances.
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance QtahDB.Bits ", String
typeName, String
" 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 :: String -> Generator ()
fun1 String
f =
              [String] -> Generator ()
LH.saysLn [String
f, String
" x = QtahFlags.numToFlags $ QtahDB.",
                         String
f, String
" $ QtahFlags.flagsToNum x"]
            fun1Int :: String -> Generator ()
fun1Int String
f =
              [String] -> Generator ()
LH.saysLn [String
f, String
" x i = QtahFlags.numToFlags $ QtahDB.",
                         String
f, String
" (QtahFlags.flagsToNum x) i"]
            fun2 :: String -> Generator ()
fun2 String
f =
              [String] -> Generator ()
LH.saysLn [String
f, String
" x y = QtahFlags.numToFlags $ QtahDB.",
                         String
f, String
" (QtahFlags.flagsToNum x) (QtahFlags.flagsToNum y)"]
            op2 :: String -> Generator ()
op2 String
op =
              [String] -> Generator ()
LH.saysLn [String
"x ", String
op, String
" y = QtahFlags.numToFlags ",
                         String
"(QtahFlags.flagsToNum x ", String
op, String
" QtahFlags.flagsToNum y)"]
        String -> Generator ()
op2 String
".&."
        String -> Generator ()
op2 String
".|."
        String -> Generator ()
fun2 String
"xor"
        String -> Generator ()
fun1 String
"complement"
        String -> Generator ()
fun1Int String
"shift"
        String -> Generator ()
fun1Int String
"rotate"
        String -> Generator ()
LH.sayLn String
"bitSize x = case QtahDB.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
          String -> Generator ()
LH.sayLn String
"  QtahP.Just n -> n"
          -- Same error message as the prelude here:
          String -> Generator ()
LH.sayLn String
"  QtahP.Nothing -> QtahP.error \"bitSize is undefined\""
        String -> Generator ()
LH.sayLn String
"bitSizeMaybe = QtahDB.bitSizeMaybe . QtahFlags.flagsToNum"
        String -> Generator ()
LH.sayLn String
"isSigned = QtahDB.isSigned . QtahFlags.flagsToNum"
        String -> Generator ()
LH.sayLn String
"testBit x i = QtahDB.testBit (QtahFlags.flagsToNum x) i"
        String -> Generator ()
LH.sayLn String
"bit = QtahFlags.numToFlags . QtahDB.bit"
        String -> Generator ()
LH.sayLn String
"popCount = QtahDB.popCount . QtahFlags.flagsToNum"

    SayExportMode
LH.SayExportBoot -> do
      -- Emit a minimal version of the regular binding code.
      String
typeName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeName Flags
flags
      String
typeclassName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeclassName Flags
flags
      String
convertFnName <- Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsConvertFnName Flags
flags
      -- We'll use the type name as the data constructor name as well:
      let ctorName :: String
ctorName = String
typeName
          enum :: CppEnum
enum = Flags -> CppEnum
flagsEnum Flags
flags
      String
enumTypeName <- CppEnum -> ReaderT Env (WriterT Output (Except String)) String
Enum.toHsEnumTypeName CppEnum
enum
      EvaluatedEnumData
enumData <- HasCallStack => ExtName -> Generator EvaluatedEnumData
ExtName -> Generator EvaluatedEnumData
Enum.hsGetEvaluatedEnumData (ExtName -> Generator EvaluatedEnumData)
-> ExtName -> Generator EvaluatedEnumData
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
Enum.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
enumData
      let numericTypeStr :: String
numericTypeStr = HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
numericType

      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
importForBits, HsImportSet
importForFlags, HsImportSet
importForPrelude]
      Generator ()
LH.ln
      String -> Generator ()
LH.addExport String
typeName
      [String] -> Generator ()
LH.saysLn [String
"newtype ", String
typeName, String
" = ", String
ctorName, String
" (", String
numericTypeStr, String
")"]
      [String] -> Generator ()
LH.saysLn [String
"instance QtahDB.Bits ", String
typeName]
      [String] -> Generator ()
LH.saysLn [String
"instance QtahP.Eq ", String
typeName]
      [String] -> Generator ()
LH.saysLn [String
"instance QtahP.Ord ", String
typeName]
      [String] -> Generator ()
LH.saysLn [String
"instance QtahP.Show ", String
typeName]
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance QtahFlags.Flags (", String
numericTypeStr, String
") ", String
enumTypeName, String
" ", String
typeName]
      Generator ()
LH.ln
      String -> Generator ()
LH.addExport' String
typeclassName
      [String] -> Generator ()
LH.saysLn [String
"class ", String
typeclassName, String
" a where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [String] -> Generator ()
LH.saysLn [String
convertFnName, String
" :: a -> ", String
typeName]
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" ", String
typeName]
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" ", String
enumTypeName]
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
typeclassName, String
" ", String
numericTypeStr]
      Generator ()
LH.ln
      [([String], Integer)]
-> (([String], Integer) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map [String] Integer -> [([String], Integer)]
forall k a. Map k a -> [(k, a)]
M.toList (Map [String] Integer -> [([String], Integer)])
-> Map [String] Integer -> [([String], Integer)]
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> Map [String] Integer
evaluatedEnumValueMap EvaluatedEnumData
enumData) ((([String], Integer) -> Generator ()) -> Generator ())
-> (([String], Integer) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \([String]
words, Integer
_) -> do
        let words' :: [String]
words' = ForeignLanguage -> CppEnum -> [String] -> [String]
Enum.enumGetOverriddenEntryName ForeignLanguage
Haskell CppEnum
enum [String]
words
        String
bindingName <- Flags
-> [String] -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsBindingName Flags
flags [String]
words'
        String -> Generator ()
LH.addExport String
bindingName
        [String] -> Generator ()
LH.saysLn [String
bindingName, String
" :: ", String
typeName]

    where checkInFlagsEnumModule :: Generator ()
checkInFlagsEnumModule = do
            Module
currentModule <- Generator Module
LH.askModule
            Module
enumModule <- ExtName -> Generator Module
LH.getExtNameModule (ExtName -> Generator Module) -> ExtName -> Generator Module
forall a b. (a -> b) -> a -> b
$ CppEnum -> ExtName
Enum.enumExtName (CppEnum -> ExtName) -> CppEnum -> ExtName
forall a b. (a -> b) -> a -> b
$ Flags -> CppEnum
flagsEnum Flags
flags
            Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module
currentModule Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
enumModule) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
              String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Flags -> String
forall a. Show a => a -> String
show Flags
flags String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CppEnum -> String
forall a. Show a => a -> String
show (Flags -> CppEnum
flagsEnum Flags
flags) String -> ShowS
forall a. [a] -> [a] -> [a]
++
              String
"are not exported from the same module."

-- | Imports and returns the Haskell type name for a 'Flags'.
toHsFlagsTypeName :: Flags -> LH.Generator String
toHsFlagsTypeName :: Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeName Flags
flags =
  String
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsFlagsTypeName" (ReaderT Env (WriterT Output (Except String)) String
 -> ReaderT Env (WriterT Output (Except String)) String)
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
  ExtName
-> String -> ReaderT Env (WriterT Output (Except String)) String
LH.addExtNameModule (Flags -> ExtName
flagsExtName Flags
flags) (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Flags -> String
toHsFlagsTypeName' Flags
flags

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

-- | Imports and returns the Haskell \"IsFooFlags\" typeclass for a 'Flags'.
toHsFlagsTypeclassName :: Flags -> LH.Generator String
toHsFlagsTypeclassName :: Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsTypeclassName Flags
flags =
  String
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsFlagsTypeclassName" (ReaderT Env (WriterT Output (Except String)) String
 -> ReaderT Env (WriterT Output (Except String)) String)
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
  ExtName
-> String -> ReaderT Env (WriterT Output (Except String)) String
LH.addExtNameModule (Flags -> ExtName
flagsExtName Flags
flags) (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Flags -> String
toHsFlagsTypeclassName' Flags
flags

-- | Pure version of 'toHsFlagsTypeclassName' that doesn't create a qualified
-- name.
toHsFlagsTypeclassName' :: Flags -> String
toHsFlagsTypeclassName' :: Flags -> String
toHsFlagsTypeclassName' Flags
flags = Char
'I'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:Flags -> String
toHsFlagsTypeName' Flags
flags

-- | Imports and returns the Haskell \"toFooFlags\" typeclass method for a
-- 'Flags', in the typeclass named with 'toHsFlagsTypeclassName'.
toHsFlagsConvertFnName :: Flags -> LH.Generator String
toHsFlagsConvertFnName :: Flags -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsConvertFnName Flags
flags =
  String
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsFlagsConvertFnName" (ReaderT Env (WriterT Output (Except String)) String
 -> ReaderT Env (WriterT Output (Except String)) String)
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
  ExtName
-> String -> ReaderT Env (WriterT Output (Except String)) String
LH.addExtNameModule (Flags -> ExtName
flagsExtName Flags
flags) (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Flags -> String
toHsFlagsConvertFnName' Flags
flags

-- | Pure version of 'toHsFlagsConvertFnName' that doesn't create a qualified
-- name.
toHsFlagsConvertFnName' :: Flags -> String
toHsFlagsConvertFnName' :: Flags -> String
toHsFlagsConvertFnName' Flags
flags = Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'o'Char -> ShowS
forall a. a -> [a] -> [a]
:Flags -> String
toHsFlagsTypeName' Flags
flags

-- | Constructs the name of the binding for a specific flags entry.
--
-- This is the equivalent enum data constructor name, converted to a valid
-- binding name by lower-casing the first letter.
toHsFlagsBindingName :: Flags -> [String] -> LH.Generator String
toHsFlagsBindingName :: Flags
-> [String] -> ReaderT Env (WriterT Output (Except String)) String
toHsFlagsBindingName Flags
flags [String]
words =
  String
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsFlagsBindingName" (ReaderT Env (WriterT Output (Except String)) String
 -> ReaderT Env (WriterT Output (Except String)) String)
-> ReaderT Env (WriterT Output (Except String)) String
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
  ExtName
-> String -> ReaderT Env (WriterT Output (Except String)) String
LH.addExtNameModule (Flags -> ExtName
flagsExtName Flags
flags) (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Flags -> [String] -> String
toHsFlagsBindingName' Flags
flags [String]
words

-- | Pure version of 'toHsFlagsBindingName' that doesn't create a qualified
-- name.
toHsFlagsBindingName' :: Flags -> [String] -> String
toHsFlagsBindingName' :: Flags -> [String] -> String
toHsFlagsBindingName' Flags
flags [String]
words =
  ShowS
lowerFirst ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ CppEnum -> [String] -> String
Enum.toHsEnumCtorName' (Flags -> CppEnum
flagsEnum Flags
flags) [String]
words