diff --git a/hoppy-std.cabal b/hoppy-std.cabal --- a/hoppy-std.cabal +++ b/hoppy-std.cabal @@ -1,5 +1,5 @@ name: hoppy-std -version: 0.4.0 +version: 0.5.0 synopsis: C++ FFI generator - Standard library bindings homepage: http://khumba.net/projects/hoppy license: Apache-2.0 @@ -19,6 +19,8 @@ include/hoppy/std/iterator.hpp , include/hoppy/std/map.hpp , include/hoppy/std/set.hpp + , include/hoppy/std/unordered_map.hpp + , include/hoppy/std/unordered_set.hpp , include/hoppy/std/utility.hpp library @@ -30,6 +32,8 @@ , Foreign.Hoppy.Generator.Std.Pair , Foreign.Hoppy.Generator.Std.Set , Foreign.Hoppy.Generator.Std.String + , Foreign.Hoppy.Generator.Std.UnorderedMap + , Foreign.Hoppy.Generator.Std.UnorderedSet , Foreign.Hoppy.Generator.Std.Vector other-modules: Foreign.Hoppy.Generator.Std.Internal @@ -38,7 +42,7 @@ base >=4.7 && <5 , filepath >=1.0 && <1.5 , haskell-src >=1.0 && <1.1 - , hoppy-generator >=0.4 && <0.5 + , hoppy-generator >=0.5 && <0.6 hs-source-dirs: src ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind default-language: Haskell2010 diff --git a/include/hoppy/std/unordered_map.hpp b/include/hoppy/std/unordered_map.hpp new file mode 100644 --- /dev/null +++ b/include/hoppy/std/unordered_map.hpp @@ -0,0 +1,43 @@ +#ifndef HOPPY_STD_UNORDERED_MAP_HPP +#define HOPPY_STD_UNORDERED_MAP_HPP + +// This file is part of Hoppy. +// +// Copyright 2015-2018 Bryan Gardiner +// +// 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. + +#include + +namespace hoppy { +namespace unordered_map { + +template +const K& getIteratorKey(const typename std::unordered_map::const_iterator& iterator) { + return iterator->first; +} + +template +V& getIteratorValue(typename std::unordered_map::iterator& iterator) { + return iterator->second; +} + +template +const V& getIteratorValue(const typename std::unordered_map::const_iterator& iterator) { + return iterator->second; +} + +} // namespace unordered_map +} // namespace hoppy + +#endif diff --git a/include/hoppy/std/unordered_set.hpp b/include/hoppy/std/unordered_set.hpp new file mode 100644 --- /dev/null +++ b/include/hoppy/std/unordered_set.hpp @@ -0,0 +1,41 @@ +#ifndef HOPPY_STD_UNORDERED_SET_HPP +#define HOPPY_STD_UNORDERED_SET_HPP + +// This file is part of Hoppy. +// +// Copyright 2015-2018 Bryan Gardiner +// +// 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. + +#include + +namespace hoppy { +namespace unordered_set { + +template +bool insert(std::unordered_set& set, const T& value) { + return set.insert(value).second; +} + +template +typename std::unordered_set::iterator insertAndGetIterator( + std::unordered_set& set, + const T& value +) { + return set.insert(value).first; +} + +} // namespace unordered_set +} // namespace hoppy + +#endif diff --git a/src/Foreign/Hoppy/Generator/Std/Set.hs b/src/Foreign/Hoppy/Generator/Std/Set.hs --- a/src/Foreign/Hoppy/Generator/Std/Set.hs +++ b/src/Foreign/Hoppy/Generator/Std/Set.hs @@ -67,6 +67,7 @@ data Contents = Contents { c_set :: Class -- ^ @std::set\@ , c_iterator :: Class -- ^ @std::set\::iterator@ + , c_constIterator :: Class -- ^ @std::set\::const_iterator@ } -- | @instantiate className t tReqs@ creates a set of bindings for an @@ -94,12 +95,14 @@ classAddFeatures (Assignable : Comparable : Copyable : optSetClassFeatures opts) $ makeClass (ident1T "std" "set" [t]) (Just $ toExtName setName) [] [ mkCtor "new" [] - , mkConstMethod "begin" [] $ toGcT $ objT iterator + , mkMethod' "begin" "begin" [] $ toGcT $ objT iterator + , mkConstMethod' "begin" "beginConst" [] $ toGcT $ objT constIterator , mkMethod "clear" [] voidT , mkConstMethod "count" [t] sizeT -- TODO count , mkConstMethod "empty" [] boolT - , mkConstMethod "end" [] $ toGcT $ objT iterator + , mkMethod' "end" "end" [] $ toGcT $ objT iterator + , mkConstMethod' "end" "endConst" [] $ toGcT $ objT constIterator -- equalRange: find is good enough. , mkMethod' "erase" "erase" [objT iterator] voidT , mkMethod' "erase" "eraseRange" [objT iterator, objT iterator] voidT @@ -117,13 +120,21 @@ ] -- Set iterators are always constant, because modifying elements in place - -- will break the internal order of the set. + -- will break the internal order of the set. That said, 'iterator' and + -- 'const_iterator' aren't guaranteed to be the same type; only that + -- 'iterator' is convertible to 'const_iterator'. iterator = addReqs reqs $ makeBidirectionalIterator Constant (Just t) $ makeClass (identT' [("std", Nothing), ("set", Just [t]), ("iterator", Nothing)]) (Just $ toExtName iteratorName) [] [] + constIterator = + addReqs reqs $ + makeBidirectionalIterator Constant (Just t) $ + makeClass (identT' [("std", Nothing), ("set", Just [t]), ("const_iterator", Nothing)]) + (Just $ toExtName iteratorName) [] [] + -- The addendum for the set class contains HasContents and FromContents -- instances. makeAddendum conversion = do @@ -146,8 +157,8 @@ setConstCast <- toHsCastMethodName Const set setEmpty <- toHsClassEntityName set "empty" - setBegin <- toHsClassEntityName set "begin" - setEnd <- toHsClassEntityName set "end" + setBeginConst <- toHsClassEntityName set "beginConst" + setEndConst <- toHsClassEntityName set "endConst" iterEq <- toHsClassEntityName iterator OpEq iterGetConst <- toHsClassEntityName iterator "getConst" iterPrev <- toHsClassEntityName iterator "prev" @@ -162,8 +173,8 @@ saysLn ["empty' <- ", setEmpty, " this'"] sayLn "if empty' then HoppyP.return [] else do" indent $ do - saysLn ["begin' <- ", setBegin, " this'"] - saysLn ["iter' <- ", setEnd, " this'"] + saysLn ["begin' <- ", setBeginConst, " this'"] + saysLn ["iter' <- ", setEndConst, " this'"] sayLn "go' iter' begin' []" sayLn "where" indent $ do @@ -201,9 +212,10 @@ in Contents { c_set = set , 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 (ExportClass . ($ m)) [c_set, c_iterator] +toExports m = map (ExportClass . ($ m)) [c_set, c_iterator, c_constIterator] diff --git a/src/Foreign/Hoppy/Generator/Std/String.hs b/src/Foreign/Hoppy/Generator/Std/String.hs --- a/src/Foreign/Hoppy/Generator/Std/String.hs +++ b/src/Foreign/Hoppy/Generator/Std/String.hs @@ -22,7 +22,7 @@ #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif -import Foreign.Hoppy.Generator.Language.Haskell (addImports, sayLn) +import Foreign.Hoppy.Generator.Language.Haskell (addExport, addImports, indent, sayLn) import Foreign.Hoppy.Generator.Spec import Foreign.Hoppy.Generator.Types import Language.Haskell.Syntax ( @@ -36,6 +36,7 @@ c_string = addReqIncludes [includeStd "string"] $ classAddFeatures [Assignable, Comparable, Copyable, Equatable] $ + addAddendumHaskell addendum $ classSetHaskellConversion ClassHaskellConversion { classHaskellConversionType = Just $ do @@ -43,16 +44,33 @@ return $ HsTyCon $ UnQual $ HsIdent "HoppyP.String" , classHaskellConversionToCppFn = Just $ do addImports $ mconcat [hsImportForPrelude, hsImportForForeignC] - sayLn "HoppyP.flip HoppyFC.withCString stdString_newFromCString" + sayLn "HoppyP.flip HoppyFC.withCStringLen stdString_newFromCStringLen" , classHaskellConversionFromCppFn = Just $ do - addImports $ mconcat [hsImport1 "Control.Monad" "(<=<)", hsImportForForeignC] - sayLn "HoppyFC.peekCString <=< stdString_c_str" + addImports $ mconcat [hsImport1 "Control.Applicative" "(<*)", + hsImportForForeignC, + hsImportForPrelude, + hsImportForRuntime] + sayLn "\\s -> do" + indent $ do + sayLn "p <- stdString_data s" + sayLn "n <- stdString_size s" + sayLn "HoppyFC.peekCStringLen (p, HoppyP.fromIntegral n) <* HoppyFHR.touchCppPtr s" } $ makeClass (ident1 "std" "string") (Just $ toExtName "StdString") [] [ mkCtor "new" [] , mkCtor "newFromCString" [ptrT $ constT charT] + , mkCtor "newFromCStringLen_raw" [ptrT $ constT charT, sizeT] , mkMethod' "at" "at" [intT] $ refT charT , mkConstMethod' "at" "get" [intT] charT , mkConstMethod "c_str" [] $ ptrT $ constT charT + , mkConstMethod "data" [] $ ptrT $ constT charT , mkConstMethod "size" [] sizeT ] + where + addendum = do + addImports $ mconcat [hsImportForPrelude, hsImportForForeignC] + addExport "stdString_newFromCStringLen" + sayLn "stdString_newFromCStringLen :: HoppyFC.CStringLen -> HoppyP.IO StdString" + sayLn "stdString_newFromCStringLen (p,n) =" + indent $ do + sayLn "stdString_newFromCStringLen_raw p (HoppyP.fromIntegral n)" diff --git a/src/Foreign/Hoppy/Generator/Std/UnorderedMap.hs b/src/Foreign/Hoppy/Generator/Std/UnorderedMap.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Std/UnorderedMap.hs @@ -0,0 +1,266 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2018 Bryan Gardiner +-- +-- 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, + toHsDataTypeName, + toHsClassEntityName, + ) +import Foreign.Hoppy.Generator.Spec +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\@ + , c_iterator :: Class -- ^ @std::unordered_map\::iterator@ + , c_constIterator :: Class -- ^ @std::unordered_map\::const_iterator@ + } + +-- | @instantiate className k v reqs@ creates a set of bindings for an +-- instantiation of @std::unordered_map\@ 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" [] + , mkMethod' "at" "at" [k] $ refT v + , mkConstMethod' "at" "atConst" [k] $ refT $ constT v + , mkMethod' "begin" "begin" [] $ toGcT $ objT iterator + , mkConstMethod' "begin" "beginConst" [] $ toGcT $ objT constIterator + , mkMethod "clear" [] voidT + , mkConstMethod "count" [k] sizeT + , mkConstMethod "empty" [] boolT + , mkMethod' "end" "end" [] $ toGcT $ objT iterator + , mkConstMethod' "end" "endConst" [] $ 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" [] sizeT + , mkConstMethod "size" [] 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 (ExportClass . ($ m)) [c_map, c_iterator, c_constIterator] diff --git a/src/Foreign/Hoppy/Generator/Std/UnorderedSet.hs b/src/Foreign/Hoppy/Generator/Std/UnorderedSet.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Std/UnorderedSet.hs @@ -0,0 +1,224 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2018 Bryan Gardiner +-- +-- 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_set@. +module Foreign.Hoppy.Generator.Std.UnorderedSet ( + 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, + toHsCastMethodName, + toHsDataTypeName, + toHsClassEntityName, + ) +import Foreign.Hoppy.Generator.Spec +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 set classes. +data Options = Options + { optUnorderedSetClassFeatures :: [ClassFeature] + -- ^ Additional features to add to the @std::unordered_set@ class. UnorderedSets are always + -- 'Assignable', 'Comparable', and 'Copyable', but you may want to add + -- 'Foreign.Hoppy.Generator.Spec.ClassFeature.Equatable' if your value type + -- supports those. + , optValueConversion :: Maybe ValueConversion + } + +-- | The default options have no additional 'ClassFeature's. +defaultOptions :: Options +defaultOptions = Options [] Nothing + +-- | A set of instantiated set classes. +data Contents = Contents + { c_set :: Class -- ^ @std::unordered_set\@ + , c_iterator :: Class -- ^ @std::unordered_set\::iterator@ + , c_constIterator :: Class -- ^ @std::unordered_set\::const_iterator@ + } + +-- | @instantiate className t tReqs@ creates a set of bindings for an +-- instantiation of @std::unordered_set@ and associated types (e.g. iterators). In the +-- result, the 'c_set' class has an external name of @className@, and the +-- iterator class is further suffixed with @\"Iterator\"@. +instantiate :: String -> Type -> Reqs -> Contents +instantiate setName t tReqs = instantiate' setName t tReqs defaultOptions + +-- | 'instantiate' with additional options. +instantiate' :: String -> Type -> Reqs -> Options -> Contents +instantiate' setName t tReqs opts = + let reqs = mconcat + [ tReqs + , reqInclude $ includeHelper "unordered_set.hpp" + , reqInclude $ includeStd "unordered_set" + ] + iteratorName = setName ++ "Iterator" + + set = + (case optValueConversion opts of + Nothing -> id + Just conversion -> addAddendumHaskell $ makeAddendum conversion) $ + addReqs reqs $ + classAddFeatures (Assignable : Copyable : optUnorderedSetClassFeatures opts) $ + makeClass (ident1T "std" "unordered_set" [t]) (Just $ toExtName setName) [] + [ mkCtor "new" [] + , mkMethod' "begin" "begin" [] $ toGcT $ objT iterator + , mkConstMethod' "begin" "beginConst" [] $ toGcT $ objT constIterator + , mkMethod "clear" [] voidT + , mkConstMethod "count" [t] sizeT + -- TODO count + , mkConstMethod "empty" [] boolT + , mkMethod' "end" "end" [] $ toGcT $ objT iterator + , mkConstMethod' "end" "endConst" [] $ toGcT $ objT constIterator + -- equalRange: find is good enough. + , mkMethod' "erase" "erase" [objT iterator] voidT + , mkMethod' "erase" "eraseRange" [objT iterator, objT iterator] voidT + , mkMethod "find" [t] $ toGcT $ objT iterator + -- TODO Replace these with a single version that returns a (toGcT std::pair). + , makeFnMethod (ident2 "hoppy" "unordered_set" "insert") "insert" + MNormal Nonpure [refT $ objT set, t] boolT + , makeFnMethod (ident2 "hoppy" "unordered_set" "insertAndGetIterator") + "insertAndGetIterator" MNormal Nonpure [refT $ objT set, t] $ toGcT $ objT iterator + -- lower_bound: find is good enough. + , mkConstMethod' "max_size" "maxSize" [] sizeT + , mkConstMethod "size" [] sizeT + , mkMethod "swap" [refT $ objT set] voidT + -- upper_bound: find is good enough. + ] + + -- Unordered set iterators are always constant, because modifying elements + -- in place will break the internal order of the set. That said, + -- 'iterator' and 'const_iterator' aren't guaranteed to be the same type + -- (indeed they're not for g++ 7.2.0 on Kubuntu 17.10 amd64); only that + -- 'iterator' is convertible to 'const_iterator'. + iterator = + addReqs reqs $ + makeForwardIterator Constant (Just t) $ + makeClass (identT' [("std", Nothing), ("unordered_set", Just [t]), ("iterator", Nothing)]) + (Just $ toExtName iteratorName) [] [] + + constIterator = + addReqs reqs $ + makeForwardIterator Constant (Just t) $ + makeClass (identT' [("std", Nothing), + ("unordered_set", Just [t]), + ("const_iterator", Nothing)]) + (Just $ toExtName iteratorName) [] [] + + -- The addendum for the unordered_set class contains HasContents and FromContents + -- instances. + makeAddendum conversion = do + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForPrelude, + hsImportForRuntime] + when (conversion == ConvertValue) $ + addImports $ mconcat [hsImport1 "Prelude" "(=<<)"] + + hsDataNameConst <- toHsDataTypeName Const set + hsDataName <- toHsDataTypeName Nonconst set + [hsValueTypeConst, hsValueType] <- forM [Const, Nonconst] $ \cst -> + cppTypeToHsTypeAndUse HsHsSide $ + (case conversion of + ConvertPtr -> ptrT + ConvertValue -> id) $ + case cst of + Const -> constT t + Nonconst -> t + + setConstCast <- toHsCastMethodName Const set + setEmpty <- toHsClassEntityName set "empty" + setBeginConst <- toHsClassEntityName set "beginConst" + setEndConst <- toHsClassEntityName set "endConst" + iterEq <- toHsClassEntityName iterator OpEq + iterGetConst <- toHsClassEntityName iterator "getConst" + iterNext <- toHsClassEntityName iterator "next" + + -- Generate const and nonconst HasContents instances. + ln + saysLn ["instance HoppyFHR.HasContents ", hsDataNameConst, + " (", prettyPrint hsValueTypeConst, ") where"] + indent $ do + sayLn "toContents this' = do" + indent $ do + saysLn ["empty' <- ", setEmpty, " this'"] + sayLn "if empty' then HoppyP.return [] else do" + indent $ do + saysLn ["end' <- ", setEndConst, " this'"] + saysLn ["iter' <- ", setBeginConst, " 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 ["value' <- ", + case conversion of + ConvertPtr -> "" + ConvertValue -> "HoppyFHR.decode =<< ", + iterGetConst, " iter'"] + sayLn "go' iter' end' $ value':acc'" + ln + saysLn ["instance HoppyFHR.HasContents ", hsDataName, + " (", prettyPrint hsValueTypeConst, ") where"] + indent $ + saysLn ["toContents = HoppyFHR.toContents . ", setConstCast] + + -- Only generate a nonconst FromContents instance. + ln + saysLn ["instance HoppyFHR.FromContents ", hsDataName, + " (", prettyPrint hsValueType, ") where"] + indent $ do + sayLn "fromContents values' = do" + indent $ do + setNew <- toHsClassEntityName set "new" + setInsert <- toHsClassEntityName set "insert" + saysLn ["set' <- ", setNew] + saysLn ["HoppyP.mapM_ (", setInsert, " set') values'"] + sayLn "HoppyP.return set'" + + in Contents + { c_set = set + , 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 (ExportClass . ($ m)) [c_set, c_iterator, c_constIterator]