module Foreign.Hoppy.Generator.Spec.Enum (
CppEnum, enumT,
makeEnum, makeAutoEnum, IsAutoEnumValue (..),
enumExtName,
enumIdentifier,
enumNumericType, enumSetNumericType,
enumValues,
enumReqs,
enumAddendum,
enumValuePrefix, enumSetValuePrefix,
enumAddEntryNameOverrides,
enumGetOverriddenEntryName,
IsEnumUnknownValueEntry (..),
enumUnknownValueEntry, enumSetUnknownValueEntry, enumSetNoUnknownValueEntry,
enumUnknownValueEntryDefault,
enumHasBitOperations, enumSetHasBitOperations,
cppGetEvaluatedEnumData,
hsGetEvaluatedEnumData,
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 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),
)
data CppEnum = CppEnum
{ enumExtName :: ExtName
, enumIdentifier :: Identifier
, enumNumericType :: Maybe Type
, enumScoped :: Scoped
, enumValues :: EnumValueMap
, enumReqs :: Reqs
, enumAddendum :: Addendum
, enumValuePrefix :: String
, enumUnknownValueEntry :: Maybe EnumEntryWords
, enumHasBitOperations :: Bool
}
instance Eq CppEnum where
(==) = (==) `on` enumExtName
instance Show CppEnum where
show e = concat ["<Enum ", show (enumExtName e), " ", show (enumIdentifier e), ">"]
instance Exportable CppEnum where
sayExportCpp _ _ = return ()
sayExportHaskell = sayHsExport
getExportEnumInfo e =
Just EnumInfo
{ enumInfoExtName = enumExtName e
, enumInfoIdentifier = enumIdentifier e
, enumInfoNumericType = enumNumericType e
, enumInfoReqs = enumReqs e
, enumInfoScoped = enumScoped e
, enumInfoValues = enumValues e
}
instance HasExtNames CppEnum where
getPrimaryExtName = enumExtName
instance HasReqs CppEnum where
getReqs = enumReqs
setReqs reqs e = e { enumReqs = reqs }
instance HasAddendum CppEnum where
getAddendum = enumAddendum
setAddendum addendum e = e { enumAddendum = addendum }
enumSetNumericType :: Maybe Type -> CppEnum -> CppEnum
enumSetNumericType maybeType enum = enum { enumNumericType = maybeType }
enumUnknownValueEntryDefault :: EnumEntryWords
enumUnknownValueEntryDefault = ["Unknown"]
makeEnum ::
Identifier
-> Maybe ExtName
-> [(Integer, EnumEntryWords)]
-> CppEnum
makeEnum identifier maybeExtName entries =
let extName = extNameOrIdentifier identifier maybeExtName
in CppEnum
extName
identifier
Nothing
Unscoped
(let entries' = for entries $ \(num, words') -> (words', EnumValueManual num)
entryNames = map fst entries'
in EnumValueMap
{ enumValueMapNames = entryNames
, enumValueMapForeignNames = plainMap $ M.fromList $ map (id &&& id) entryNames
, enumValueMapValues = M.fromList entries'
})
mempty
mempty
(fromExtName extName ++ "_")
(Just enumUnknownValueEntryDefault)
True
makeAutoEnum ::
IsAutoEnumValue v
=> Identifier
-> Maybe ExtName
-> Scoped
-> [v]
-> CppEnum
makeAutoEnum identifier maybeExtName scoped entries =
let extName = extNameOrIdentifier identifier maybeExtName
in CppEnum
extName
identifier
Nothing
scoped
(let namespaceForValues = case scoped of
Scoped -> identifier
Unscoped -> makeIdentifier $ butLast $ identifierParts identifier
entries' =
map (fmap (\name -> namespaceForValues `mappend` ident name) .
toAutoEnumValue)
entries
entryNames = map fst entries'
in EnumValueMap
{ enumValueMapNames = entryNames
, enumValueMapForeignNames = plainMap $ M.fromList $ map (id &&& id) entryNames
, enumValueMapValues = M.map EnumValueAuto $ M.fromList entries'
})
mempty
mempty
(fromExtName extName ++ "_")
(Just enumUnknownValueEntryDefault)
True
class IsAutoEnumValue a where
toAutoEnumValue :: a -> (EnumEntryWords, String)
instance IsAutoEnumValue (EnumEntryWords, String) where
toAutoEnumValue = id
instance IsAutoEnumValue String where
toAutoEnumValue = splitIntoWords &&& id
enumAddEntryNameOverrides :: IsAutoEnumValue v => ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum
enumAddEntryNameOverrides lang nameOverrides enum = enum { enumValues = enumValues' }
where enumValues' =
(enumValues enum)
{ enumValueMapForeignNames =
addOverrideMap lang overrideMap $ enumValueMapForeignNames $ enumValues enum }
overrideMap = M.fromList $ map (toEntryName *** toEntryName) nameOverrides
toEntryName = fst . toAutoEnumValue
enumGetOverriddenEntryName :: ForeignLanguage -> CppEnum -> EnumEntryWords -> EnumEntryWords
enumGetOverriddenEntryName lang enum words' =
case overriddenMapLookup lang words' $ enumValueMapForeignNames $ enumValues enum of
Just words'' -> words''
Nothing ->
error $ "enumGetOverriddenEntryName: Entry with name " ++ show words' ++
" not found in " ++ show enum ++ "."
enumSetValuePrefix :: String -> CppEnum -> CppEnum
enumSetValuePrefix prefix enum = enum { enumValuePrefix = prefix }
enumSetUnknownValueEntry :: IsEnumUnknownValueEntry a => a -> CppEnum -> CppEnum
enumSetUnknownValueEntry name enum =
enum { enumUnknownValueEntry = Just $ toEnumUnknownValueEntry name }
enumSetNoUnknownValueEntry :: CppEnum -> CppEnum
enumSetNoUnknownValueEntry enum =
enum { enumUnknownValueEntry = Nothing }
class IsEnumUnknownValueEntry a where
toEnumUnknownValueEntry :: a -> EnumEntryWords
instance IsEnumUnknownValueEntry EnumEntryWords where
toEnumUnknownValueEntry = id
instance IsEnumUnknownValueEntry String where
toEnumUnknownValueEntry = splitIntoWords
enumSetHasBitOperations :: Bool -> CppEnum -> CppEnum
enumSetHasBitOperations b enum = enum { enumHasBitOperations = b }
makeConversion :: CppEnum -> ConversionSpec
makeConversion e =
(makeConversionSpec (show e) cpp)
{ conversionSpecHaskell = Just hs }
where cpp =
makeConversionSpecCpp (LC.renderIdentifier $ enumIdentifier e)
(return $ enumReqs e)
hs =
makeConversionSpecHaskell
(HsTyCon . UnQual . HsIdent <$> toHsEnumTypeName e)
(Just $ do evaluatedData <- hsGetEvaluatedEnumData $ enumExtName e
LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData)
(CustomConversion $ do
LH.addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForPrelude,
hsImportForRuntime]
LH.sayLn "HoppyP.return . HoppyFHR.fromCppEnum")
(CustomConversion $ do
LH.addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForPrelude,
hsImportForRuntime]
LH.sayLn "HoppyP.return . HoppyFHR.toCppEnum")
enumT :: CppEnum -> Type
enumT = manualT . makeConversion
sayHsExport :: LH.SayExportMode -> CppEnum -> LH.Generator ()
sayHsExport mode enum =
LH.withErrorContext ("generating enum " ++ show (enumExtName enum)) $
case mode of
LH.SayExportForeignImports -> return ()
LH.SayExportDecls -> do
hsTypeName <- toHsEnumTypeName enum
evaluatedData <- hsGetEvaluatedEnumData $ enumExtName enum
numericType <- LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData
let evaluatedValueMap = evaluatedEnumValueMap evaluatedData
evaluatedValues <- forM (enumValueMapNames $ enumValues enum) $ \name ->
case M.lookup name evaluatedValueMap of
Just value -> return (name, value)
Nothing -> throwError $ "Couldn't find evaluated value for " ++ show name
values :: [(Integer, String)] <- forM evaluatedValues $ \(entryName, value) -> do
let entryName' = enumGetOverriddenEntryName Haskell enum entryName
ctorName <- toHsEnumCtorName enum entryName'
return (value, ctorName)
maybeUnknownValueCtorName <- forM (enumUnknownValueEntry enum) $ toHsEnumCtorName enum
LH.addImports $ mconcat [hsImport1 "Prelude" "(==)",
hsImportForPrelude,
hsImportForRuntime]
LH.ln
LH.addExport' hsTypeName
LH.saysLn ["data ", hsTypeName, " ="]
LH.indent $ do
forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) ->
LH.saysLn [if cont then "| " else "", hsCtorName]
forM_ maybeUnknownValueCtorName $ \unknownValueCtorName ->
LH.saysLn ["| ", unknownValueCtorName, " (", LH.prettyPrint numericType, ")"]
LH.sayLn "deriving (HoppyP.Show)"
LH.ln
LH.saysLn ["instance HoppyFHR.CppEnum (", LH.prettyPrint numericType, ") ", hsTypeName,
" where"]
LH.indent $ do
forM_ values $ \(num, hsCtorName) ->
LH.saysLn ["fromCppEnum ", hsCtorName, " = ", show num]
forM_ maybeUnknownValueCtorName $ \unknownValueCtorName ->
LH.saysLn ["fromCppEnum (", unknownValueCtorName, " n) = n"]
LH.ln
forM_ (M.toList $ M.fromListWith const values) $ \(num, hsCtorName) ->
LH.saysLn ["toCppEnum (", show num, ") = ", hsCtorName]
case maybeUnknownValueCtorName of
Just unknownValueCtorName -> LH.saysLn ["toCppEnum n = ", unknownValueCtorName, " n"]
Nothing -> do
LH.addImports $ hsImports "Prelude" ["($)", "(++)"]
LH.saysLn ["toCppEnum n' = HoppyP.error $ ",
show (concat ["Unknown ", hsTypeName, " numeric value: "]),
" ++ HoppyP.show n'"]
LH.ln
LH.saysLn ["instance HoppyP.Eq ", hsTypeName, " where"]
LH.indent $
LH.sayLn "x == y = HoppyFHR.fromCppEnum x == HoppyFHR.fromCppEnum y"
LH.ln
LH.saysLn ["instance HoppyP.Ord ", hsTypeName, " where"]
LH.indent $
LH.sayLn "compare x y = HoppyP.compare (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)"
when (enumHasBitOperations enum) $ do
LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],
hsImports "Data.Bits" ["(.&.)", "(.|.)"],
hsImportForBits]
LH.saysLn ["instance HoppyDB.Bits ", hsTypeName, " where"]
LH.indent $ do
let fun1 f =
LH.saysLn [f, " x = HoppyFHR.toCppEnum $ HoppyDB.",
f, " $ HoppyFHR.fromCppEnum x"]
fun1Int f =
LH.saysLn [f, " x i = HoppyFHR.toCppEnum $ HoppyDB.",
f, " (HoppyFHR.fromCppEnum x) i"]
fun2 f =
LH.saysLn [f, " x y = HoppyFHR.toCppEnum $ HoppyDB.",
f, " (HoppyFHR.fromCppEnum x) (HoppyFHR.fromCppEnum y)"]
op2 op =
LH.saysLn ["x ", op, " y = HoppyFHR.toCppEnum ",
"(HoppyFHR.fromCppEnum x ", op, " HoppyFHR.fromCppEnum y)"]
op2 ".&."
op2 ".|."
fun2 "xor"
fun1 "complement"
fun1Int "shift"
fun1Int "rotate"
LH.sayLn "bitSize x = case HoppyDB.bitSizeMaybe x of"
LH.indent $ do
LH.sayLn " HoppyP.Just n -> n"
LH.sayLn " HoppyP.Nothing -> HoppyP.error \"bitSize is undefined\""
LH.sayLn "bitSizeMaybe = HoppyDB.bitSizeMaybe . HoppyFHR.fromCppEnum"
LH.sayLn "isSigned = HoppyDB.isSigned . HoppyFHR.fromCppEnum"
LH.sayLn "testBit x i = HoppyDB.testBit (HoppyFHR.fromCppEnum x) i"
LH.sayLn "bit = HoppyFHR.toCppEnum . HoppyDB.bit"
LH.sayLn "popCount = HoppyDB.popCount . HoppyFHR.fromCppEnum"
LH.SayExportBoot -> do
hsTypeName <- toHsEnumTypeName enum
evaluatedData <- hsGetEvaluatedEnumData $ enumExtName enum
numericType <- LH.cppTypeToHsTypeAndUse LH.HsCSide $ evaluatedEnumType evaluatedData
LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
LH.addExport hsTypeName
LH.ln
LH.saysLn ["data ", hsTypeName]
LH.saysLn ["instance HoppyFHR.CppEnum (", LH.prettyPrint numericType, ") ", hsTypeName]
LH.saysLn ["instance HoppyP.Eq ", hsTypeName]
LH.saysLn ["instance HoppyP.Ord ", hsTypeName]
LH.saysLn ["instance HoppyP.Show ", hsTypeName]
when (enumHasBitOperations enum) $ do
LH.addImports hsImportForBits
LH.saysLn ["instance HoppyDB.Bits ", hsTypeName]
cppGetEvaluatedEnumData :: HasCallStack => ExtName -> LC.Generator EvaluatedEnumData
cppGetEvaluatedEnumData extName = do
iface <- LC.askInterface
return $ interfaceGetEvaluatedEnumData iface extName
hsGetEvaluatedEnumData :: HasCallStack => ExtName -> LH.Generator EvaluatedEnumData
hsGetEvaluatedEnumData extName = do
iface <- LH.askInterface
return $ interfaceGetEvaluatedEnumData iface extName
toHsEnumTypeName :: CppEnum -> LH.Generator String
toHsEnumTypeName enum =
LH.inFunction "toHsEnumTypeName" $
LH.addExtNameModule (enumExtName enum) $ toHsEnumTypeName' enum
toHsEnumTypeName' :: CppEnum -> String
toHsEnumTypeName' = LH.toHsTypeName' Nonconst . enumExtName
toHsEnumCtorName :: CppEnum -> EnumEntryWords -> LH.Generator String
toHsEnumCtorName enum words' =
LH.inFunction "toHsEnumCtorName" $
LH.addExtNameModule (enumExtName enum) $ toHsEnumCtorName' enum words'
toHsEnumCtorName' :: CppEnum -> EnumEntryWords -> String
toHsEnumCtorName' enum words' =
concat $ enumValuePrefix enum : map capitalize words'