module Foreign.Hoppy.Generator.Std.Set (
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
data Options = Options
{ optSetClassFeatures :: [ClassFeature]
, optValueConversion :: Maybe ValueConversion
}
defaultOptions :: Options
defaultOptions = Options [] Nothing
data Contents = Contents
{ c_set :: Class
, c_iterator :: Class
}
instantiate :: String -> Type -> Reqs -> Contents
instantiate setName t tReqs = instantiate' setName t tReqs defaultOptions
instantiate' :: String -> Type -> Reqs -> Options -> Contents
instantiate' setName t tReqs opts =
let reqs = mconcat
[ tReqs
, reqInclude $ includeHelper "set.hpp"
, reqInclude $ includeStd "set"
]
iteratorName = setName ++ "Iterator"
set =
(case optValueConversion opts of
Nothing -> id
Just conversion -> addAddendumHaskell $ makeAddendum conversion) $
addReqs reqs $
classAddFeatures (Assignable : Comparable : Copyable : optSetClassFeatures opts) $
makeClass (ident1T "std" "set" [t]) (Just $ toExtName setName) []
[ mkCtor "new" []
, mkConstMethod "begin" [] $ toGcT $ objT iterator
, mkMethod "clear" [] voidT
, mkConstMethod "count" [t] sizeT
, mkConstMethod "empty" [] boolT
, mkConstMethod "end" [] $ toGcT $ objT iterator
, mkMethod' "erase" "erase" [objT iterator] voidT
, mkMethod' "erase" "eraseRange" [objT iterator, objT iterator] voidT
, mkMethod "find" [t] $ toGcT $ objT iterator
, makeFnMethod (ident2 "hoppy" "set" "insert") "insert"
MNormal Nonpure [refT $ objT set, t] boolT
, makeFnMethod (ident2 "hoppy" "set" "insertAndGetIterator") "insertAndGetIterator"
MNormal Nonpure [refT $ objT set, t] $ toGcT $ objT iterator
, mkConstMethod' "max_size" "maxSize" [] sizeT
, mkConstMethod "size" [] sizeT
, mkMethod "swap" [refT $ objT set] voidT
]
iterator =
addReqs reqs $
makeBidirectionalIterator Constant (Just t) $
makeClass (identT' [("std", Nothing), ("set", Just [t]), ("iterator", Nothing)])
(Just $ toExtName iteratorName) [] []
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"
setBegin <- toHsClassEntityName set "begin"
setEnd <- toHsClassEntityName set "end"
iterEq <- toHsClassEntityName iterator OpEq
iterGetConst <- toHsClassEntityName iterator "getConst"
iterPrev <- toHsClassEntityName iterator "prev"
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 ["begin' <- ", setBegin, " this'"]
saysLn ["iter' <- ", setEnd, " this'"]
sayLn "go' iter' begin' []"
sayLn "where"
indent $ do
sayLn "go' iter' begin' acc' = do"
indent $ do
saysLn ["stop' <- ", iterEq, " iter' begin'"]
sayLn "if stop' then HoppyP.return acc' else do"
indent $ do
saysLn ["_ <- ", iterPrev, " iter'"]
saysLn ["value' <- ",
case conversion of
ConvertPtr -> ""
ConvertValue -> "HoppyFHR.decode =<< ",
iterGetConst, " iter'"]
sayLn "go' iter' begin' $ value':acc'"
ln
saysLn ["instance HoppyFHR.HasContents ", hsDataName,
" (", prettyPrint hsValueTypeConst, ") where"]
indent $
saysLn ["toContents = HoppyFHR.toContents . ", setConstCast]
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
}
toExports :: Contents -> [Export]
toExports m = map (ExportClass . ($ m)) [c_set, c_iterator]