hoppy-std-0.7.1: src/Foreign/Hoppy/Generator/Std/UnorderedMap.hs
-- This file is part of Hoppy.
--
-- Copyright 2015-2020 Bryan Gardiner <bog@khumba.net>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
{-# LANGUAGE CPP #-}
-- | Bindings for @std::unordered_map@.
module Foreign.Hoppy.Generator.Std.UnorderedMap (
Options (..),
defaultOptions,
Contents (..),
instantiate,
instantiate',
toExports,
) where
import Control.Monad (forM_, when)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mconcat)
#endif
import Foreign.Hoppy.Generator.Language.Haskell (
HsTypeSide (HsHsSide),
addImports,
cppTypeToHsTypeAndUse,
indent,
ln,
prettyPrint,
sayLn,
saysLn,
)
import Foreign.Hoppy.Generator.Spec (
Constness (Const, Nonconst),
Export (Export),
Operator (OpArray, OpEq),
Purity (Nonpure),
Reqs,
Type,
addAddendumHaskell,
addReqs,
hsImports,
hsImportForPrelude,
hsImportForRuntime,
ident1T,
ident2T,
ident2,
identT',
includeStd,
np,
reqInclude,
toExtName,
)
import Foreign.Hoppy.Generator.Spec.Class (
Class,
MethodApplicability (MConst, MNormal),
makeClass,
makeFnMethod,
mkConstMethod,
mkConstMethod',
mkCtor,
mkMethod,
mkMethod',
toHsDataTypeName,
toHsClassEntityName,
)
import Foreign.Hoppy.Generator.Spec.ClassFeature (
ClassFeature (Assignable, Copyable),
classAddFeatures,
)
import Foreign.Hoppy.Generator.Std (ValueConversion (ConvertPtr, ConvertValue))
import Foreign.Hoppy.Generator.Std.Internal (includeHelper)
import Foreign.Hoppy.Generator.Std.Iterator
import Foreign.Hoppy.Generator.Types
-- | Options for instantiating the map classes.
data Options = Options
{ optUnorderedMapClassFeatures :: [ClassFeature]
-- ^ Additional features to add to the @std::unordered_map@ class. UnorderedMaps are always
-- 'Assignable' and 'Copyable'.
, optKeyConversion :: Maybe ValueConversion
-- ^ How to convert values of the key type.
, optValueConversion :: Maybe ValueConversion
-- ^ How to convert values of the value type.
}
-- | The default options have no additional 'ClassFeature's.
defaultOptions :: Options
defaultOptions = Options [] Nothing Nothing
-- | A set of instantiated map classes.
data Contents = Contents
{ c_map :: Class -- ^ @std::unordered_map\<K, V>@
, c_iterator :: Class -- ^ @std::unordered_map\<K, V>::iterator@
, c_constIterator :: Class -- ^ @std::unordered_map\<K, V>::const_iterator@
}
-- | @instantiate className k v reqs@ creates a set of bindings for an
-- instantiation of @std::unordered_map\<k, v\>@ and associated types (e.g. iterators).
-- In the result, the 'c_map' class has an external name of @className@, and the
-- iterator classes are further suffixed with @\"Iterator\"@ and
-- @\"ConstIterator\"@ respectively.
instantiate :: String -> Type -> Type -> Reqs -> Contents
instantiate mapName k v reqs = instantiate' mapName k v reqs defaultOptions
-- | 'instantiate' with additional options.
instantiate' :: String -> Type -> Type -> Reqs -> Options -> Contents
instantiate' mapName k v userReqs opts =
let extName = toExtName mapName
reqs = mconcat
[ userReqs
, reqInclude $ includeHelper "unordered_map.hpp"
, reqInclude $ includeStd "unordered_map"
]
iteratorName = mapName ++ "Iterator"
constIteratorName = mapName ++ "ConstIterator"
getIteratorKeyIdent = ident2T "hoppy" "unordered_map" "getIteratorKey" [k, v]
getIteratorValueIdent = ident2T "hoppy" "unordered_map" "getIteratorValue" [k, v]
map' =
(case (optKeyConversion opts, optValueConversion opts) of
(Nothing, Nothing) -> id
(Just keyConv, Just valueConv) -> addAddendumHaskell $ makeAddendum keyConv valueConv
(maybeKeyConv, maybeValueConv) ->
error $ concat
["Error instantiating std::unordered_map<", show k, ", ", show v, "> (external name ",
show extName, "), key and value conversions must either both be specified or ",
"absent; they are, repectively, ", show maybeKeyConv, " and ", show maybeValueConv,
"."]) $
addReqs reqs $
classAddFeatures (Assignable : Copyable : optUnorderedMapClassFeatures opts) $
makeClass (ident1T "std" "unordered_map" [k, v]) (Just extName) []
[ mkCtor "new" np
, mkMethod' "at" "at" [k] $ refT v
, mkConstMethod' "at" "atConst" [k] $ refT $ constT v
, mkMethod' "begin" "begin" np $ toGcT $ objT iterator
, mkConstMethod' "begin" "beginConst" np $ toGcT $ objT constIterator
, mkMethod "clear" np voidT
, mkConstMethod "count" [k] sizeT
, mkConstMethod "empty" np boolT
, mkMethod' "end" "end" np $ toGcT $ objT iterator
, mkConstMethod' "end" "endConst" np $ toGcT $ objT constIterator
-- equal_range: find is good enough.
, mkMethod' "erase" "erase" [objT iterator] voidT
, mkMethod' "erase" "eraseKey" [k] sizeT
, mkMethod' "erase" "eraseRange" [objT iterator, objT iterator] voidT
, mkMethod' "find" "find" [k] $ toGcT $ objT iterator
, mkConstMethod' "find" "findConst" [k] $ toGcT $ objT constIterator
-- TODO insert
-- lower_bound: find is good enough.
, mkConstMethod' "max_size" "maxSize" np sizeT
, mkConstMethod "size" np sizeT
, mkMethod "swap" [refT $ objT map'] voidT
-- upper_bound: find is good enough.
, mkMethod OpArray [k] $ refT v
]
iterator =
addReqs reqs $
makeForwardIterator Mutable Nothing $
makeClass (identT' [("std", Nothing),
("unordered_map", Just [k, v]),
("iterator", Nothing)])
(Just $ toExtName iteratorName) []
[ makeFnMethod getIteratorKeyIdent "getKey" MConst Nonpure
[objT iterator] $ refT $ constT k
, makeFnMethod getIteratorValueIdent "getValue" MNormal Nonpure
[refT $ objT iterator] $ refT v
, makeFnMethod getIteratorValueIdent "getValueConst" MConst Nonpure
[objT iterator] $ refT $ constT v
]
constIterator =
addReqs reqs $
makeForwardIterator Constant Nothing $
makeClass (identT' [("std", Nothing),
("unordered_map", Just [k, v]),
("const_iterator", Nothing)])
(Just $ toExtName constIteratorName)
[]
[ mkCtor "newFromConst" [objT iterator]
, makeFnMethod (ident2 "hoppy" "iterator" "deconst") "deconst" MConst Nonpure
[objT constIterator, refT $ objT map'] $ toGcT $ objT iterator
, makeFnMethod getIteratorKeyIdent "getKey" MConst Nonpure
[objT constIterator] $ refT $ constT k
, makeFnMethod getIteratorValueIdent "getValueConst" MConst Nonpure
[objT constIterator] $ refT $ constT v
]
-- The addendum for the map class contains HasContents and FromContents
-- instances with that work with key-value pairs.
makeAddendum keyConv valueConv = do
addImports $ mconcat [hsImports "Prelude" ["($)", "(=<<)"],
hsImportForPrelude,
hsImportForRuntime]
forM_ [Const, Nonconst] $ \cst -> do
hsDataTypeName <- toHsDataTypeName cst map'
keyHsType <-
cppTypeToHsTypeAndUse HsHsSide $
(case keyConv of
ConvertPtr -> ptrT
ConvertValue -> id) $
constT k
valueHsType <-
cppTypeToHsTypeAndUse HsHsSide $
(case valueConv of
ConvertPtr -> ptrT
ConvertValue -> id) $
case cst of
Const -> constT v
Nonconst -> v
-- Generate const and nonconst HasContents instances.
ln
saysLn ["instance HoppyFHR.HasContents ", hsDataTypeName,
" ((", prettyPrint keyHsType, "), (", prettyPrint valueHsType, ")) where"]
indent $ do
sayLn "toContents this' = do"
indent $ do
mapEmpty <- toHsClassEntityName map' "empty"
mapBegin <- toHsClassEntityName map' $ case cst of
Const -> "beginConst"
Nonconst -> "begin"
mapEnd <- toHsClassEntityName map' $ case cst of
Const -> "endConst"
Nonconst -> "end"
let iter = case cst of
Const -> constIterator
Nonconst -> iterator
iterEq <- toHsClassEntityName iter OpEq
iterGetKey <- toHsClassEntityName iter "getKey"
iterGetValue <- toHsClassEntityName iter $ case cst of
Const -> "getValueConst"
Nonconst -> "getValue"
iterNext <- toHsClassEntityName iter "next"
saysLn ["empty' <- ", mapEmpty, " this'"]
sayLn "if empty' then HoppyP.return [] else do"
indent $ do
saysLn ["end' <- ", mapEnd, " this'"]
saysLn ["iter' <- ", mapBegin, " this'"]
sayLn "go' iter' end' []"
sayLn "where"
indent $ do
sayLn "go' iter' end' acc' = do"
indent $ do
saysLn ["stop' <- ", iterEq, " iter' end'"]
sayLn "if stop' then HoppyP.return (HoppyP.reverse acc') else do"
indent $ do
saysLn ["_ <- ", iterNext, " iter'"]
saysLn ["key' <- ",
case keyConv of
ConvertPtr -> ""
ConvertValue -> "HoppyFHR.decode =<< ",
iterGetKey, " iter'"]
saysLn ["value' <- ",
case valueConv of
ConvertPtr -> ""
ConvertValue -> "HoppyFHR.decode =<< ",
iterGetValue, " iter'"]
sayLn "go' iter' end' $ (key', value'):acc'"
-- Only generate a nonconst FromContents instance.
when (cst == Nonconst) $ do
ln
saysLn ["instance HoppyFHR.FromContents ", hsDataTypeName,
" ((", prettyPrint keyHsType, "), (", prettyPrint valueHsType, ")) where"]
indent $ do
sayLn "fromContents values' = do"
indent $ do
mapNew <- toHsClassEntityName map' "new"
mapAt <- toHsClassEntityName map' "at"
saysLn ["map' <- ", mapNew]
saysLn ["HoppyP.mapM_ (\\(k, v) -> HoppyP.flip HoppyFHR.assign v =<< ",
mapAt, " map' k) values'"]
sayLn "HoppyP.return map'"
in Contents
{ c_map = map'
, c_iterator = iterator
, c_constIterator = constIterator
}
-- | Converts an instantiation into a list of exports to be included in a
-- module.
toExports :: Contents -> [Export]
toExports m = map (Export . ($ m)) [c_map, c_iterator, c_constIterator]