module Foreign.Hoppy.Generator.Std.Map (
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,
toHsMethodName',
)
import Foreign.Hoppy.Generator.Spec
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
data Options = Options
{ optMapClassFeatures :: [ClassFeature]
, optKeyConversion :: Maybe ValueConversion
, optValueConversion :: Maybe ValueConversion
}
defaultOptions :: Options
defaultOptions = Options [] Nothing Nothing
data Contents = Contents
{ c_map :: Class
, c_iterator :: Class
, c_constIterator :: Class
}
instantiate :: String -> Type -> Type -> Reqs -> Contents
instantiate mapName k v reqs = instantiate' mapName k v reqs defaultOptions
instantiate' :: String -> Type -> Type -> Reqs -> Options -> Contents
instantiate' mapName k v userReqs opts =
let extName = toExtName mapName
reqs = mconcat
[ userReqs
, reqInclude $ includeHelper "map.hpp"
, reqInclude $ includeStd "map"
]
iteratorName = mapName ++ "Iterator"
constIteratorName = mapName ++ "ConstIterator"
getIteratorKeyIdent = ident2T "hoppy" "map" "getIteratorKey" [k, v]
getIteratorValueIdent = ident2T "hoppy" "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::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 : optMapClassFeatures opts) $
makeClass (ident1T "std" "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
, 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
, mkConstMethod' "max_size" "maxSize" [] sizeT
, mkConstMethod "size" [] sizeT
, mkMethod "swap" [refT $ objT map] voidT
, mkMethod OpArray [k] $ refT v
]
iterator =
addReqs reqs $
makeBidirectionalIterator Mutable Nothing $
makeClass (identT' [("std", Nothing),
("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 $
makeBidirectionalIterator Constant Nothing $
makeClass (identT' [("std", Nothing),
("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
]
makeAddendum keyConv valueConv = do
addImports $ mconcat [hsImports "Prelude" ["($)", "(=<<)"],
hsImportForPrelude,
hsImportForRuntime]
forM_ [Const, Nonconst] $ \cst -> do
let 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
ln
saysLn ["instance HoppyFHR.HasContents ", hsDataTypeName,
" ((", prettyPrint keyHsType, "), (", prettyPrint valueHsType, ")) where"]
indent $ do
sayLn "toContents this' = do"
indent $ do
let mapBegin = case cst of
Const -> "beginConst"
Nonconst -> "begin"
mapEnd = case cst of
Const -> "endConst"
Nonconst -> "end"
iter = case cst of
Const -> constIterator
Nonconst -> iterator
iterGetValue = case cst of
Const -> "getValueConst"
Nonconst -> "getValue"
saysLn ["empty' <- ", toHsMethodName' map "empty", " this'"]
sayLn "if empty' then HoppyP.return [] else do"
indent $ do
saysLn ["begin' <- ", toHsMethodName' map mapBegin, " this'"]
saysLn ["iter' <- ", toHsMethodName' map mapEnd, " this'"]
sayLn "go' iter' begin' []"
sayLn "where"
indent $ do
sayLn "go' iter' begin' acc' = do"
indent $ do
saysLn ["stop' <- ", toHsMethodName' iter OpEq, " iter' begin'"]
sayLn "if stop' then HoppyP.return acc' else do"
indent $ do
saysLn ["_ <- ", toHsMethodName' iter "prev", " iter'"]
saysLn ["key' <- ",
case keyConv of
ConvertPtr -> ""
ConvertValue -> "HoppyFHR.decode =<< ",
toHsMethodName' iter "getKey", " iter'"]
saysLn ["value' <- ",
case valueConv of
ConvertPtr -> ""
ConvertValue -> "HoppyFHR.decode =<< ",
toHsMethodName' iter iterGetValue, " iter'"]
sayLn "go' iter' begin' $ (key', value'):acc'"
when (cst == Nonconst) $ do
ln
saysLn ["instance HoppyFHR.FromContents ", hsDataTypeName,
" ((", prettyPrint keyHsType, "), (", prettyPrint valueHsType, ")) where"]
indent $ do
sayLn "fromContents values' = do"
indent $ do
saysLn ["map' <- ", toHsMethodName' map "new"]
saysLn ["HoppyP.mapM_ (\\(k, v) -> HoppyP.flip HoppyFHR.assign v =<< ",
toHsMethodName' map "at", " map' k) values'"]
sayLn "HoppyP.return map'"
in Contents
{ c_map = map
, c_iterator = iterator
, c_constIterator = constIterator
}
toExports :: Contents -> [Export]
toExports m = map (ExportClass . ($ m)) [c_map, c_iterator, c_constIterator]