module Foreign.Hoppy.Generator.Std.List (
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.Iterator
import Foreign.Hoppy.Generator.Types
import Foreign.Hoppy.Generator.Version (collect, just, test)
data Options = Options
{ optListClassFeatures :: [ClassFeature]
, optValueConversion :: Maybe ValueConversion
}
defaultOptions :: Options
defaultOptions = Options [] Nothing
data Contents = Contents
{ c_list :: Class
, c_iterator :: Class
, c_constIterator :: Class
}
instantiate :: String -> Type -> Reqs -> Contents
instantiate listName t tReqs = instantiate' listName t tReqs defaultOptions
instantiate' :: String -> Type -> Reqs -> Options -> Contents
instantiate' listName t tReqs opts =
let reqs = mconcat [tReqs, reqInclude $ includeStd "list"]
iteratorName = listName ++ "Iterator"
constIteratorName = listName ++ "ConstIterator"
features = Assignable : Copyable : optListClassFeatures opts
list =
(case optValueConversion opts of
Nothing -> id
Just conversion -> addAddendumHaskell $ makeAddendum conversion) $
addReqs reqs $
classAddFeatures features $
makeClass (ident1T "std" "list" [t]) (Just $ toExtName listName) [] $
collect
[ just $ mkCtor "new" []
, just $ mkMethod' "back" "back" [] $ refT t
, just $ mkConstMethod' "back" "backConst" [] $ refT $ constT t
, just $ mkMethod' "begin" "begin" [] $ toGcT $ objT iterator
, just $ mkConstMethod' "begin" "beginConst" [] $ toGcT $ objT constIterator
, just $ mkMethod "clear" [] voidT
, just $ mkConstMethod "empty" [] boolT
, just $ mkMethod' "end" "end" [] $ toGcT $ objT iterator
, just $ mkConstMethod' "end" "endConst" [] $ toGcT $ objT constIterator
, just $ mkMethod' "erase" "erase" [objT iterator] voidT
, just $ mkMethod' "erase" "eraseRange" [objT iterator, objT iterator] voidT
, just $ mkMethod' "front" "front" [] $ refT t
, just $ mkConstMethod' "front" "frontConst" [] $ refT $ constT t
, just $ mkMethod "insert" [objT iterator, t] $ toGcT $ objT iterator
, just $ mkConstMethod' "max_size" "maxSize" [] sizeT
, test (elem Comparable features) $ mkMethod "merge" [refT $ objT list] voidT
, just $ mkMethod' "pop_back" "popBack" [] voidT
, just $ mkMethod' "pop_front" "popFront" [] voidT
, just $ mkMethod' "push_back" "pushBack" [t] voidT
, just $ mkMethod' "push_front" "pushFront" [t] voidT
, test (elem Equatable features) $ mkMethod "remove" [t] voidT
, just $ mkMethod' "resize" "resize" [sizeT] voidT
, just $ mkMethod' "resize" "resizeWith" [sizeT, t] voidT
, just $ mkMethod "reverse" [] voidT
, just $ mkConstMethod "size" [] sizeT
, test (elem Comparable features) $ mkMethod "sort" [] voidT
, just $ mkMethod' "splice" "spliceAll" [objT iterator, refT $ objT list] voidT
, just $ mkMethod' "splice" "spliceOne"
[objT iterator, refT $ objT list, objT iterator] voidT
, just $ mkMethod' "splice" "spliceRange"
[objT iterator, refT $ objT list, objT iterator, objT iterator] voidT
, just $ mkMethod "swap" [refT $ objT list] voidT
, test (Equatable `elem` features) $ mkMethod "unique" [] voidT
]
iterator =
addReqs reqs $
makeBidirectionalIterator Mutable (Just t) $
makeClass (identT' [("std", Nothing), ("list", Just [t]), ("iterator", Nothing)])
(Just $ toExtName iteratorName) [] []
constIterator =
addReqs reqs $
makeBidirectionalIterator Constant (Just t) $
makeClass (identT' [("std", Nothing), ("list", Just [t]), ("const_iterator", Nothing)])
(Just $ toExtName constIteratorName)
[]
[ mkCtor "newFromConst" [objT iterator]
, makeFnMethod (ident2 "hoppy" "iterator" "deconst") "deconst" MConst Nonpure
[objT constIterator, refT $ objT list] $ toGcT $ objT iterator
]
makeAddendum conversion = do
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForPrelude,
hsImportForRuntime]
when (conversion == ConvertValue) $
addImports $ hsImport1 "Prelude" "(=<<)"
forM_ [Const, Nonconst] $ \cst -> do
hsDataTypeName <- toHsDataTypeName cst list
hsValueType <-
cppTypeToHsTypeAndUse HsHsSide $
(case conversion of
ConvertPtr -> ptrT
ConvertValue -> id) $
case cst of
Const -> constT t
Nonconst -> t
ln
saysLn ["instance HoppyFHR.HasContents ", hsDataTypeName,
" (", prettyPrint hsValueType, ") where"]
indent $ do
sayLn "toContents this' = do"
indent $ do
listEmpty <- toHsClassEntityName list "empty"
listBegin <- toHsClassEntityName list $ case cst of
Const -> "beginConst"
Nonconst -> "begin"
listEnd <- toHsClassEntityName list $ case cst of
Const -> "endConst"
Nonconst -> "end"
let iter = case cst of
Const -> constIterator
Nonconst -> iterator
iterEq <- toHsClassEntityName iter OpEq
iterGet <- toHsClassEntityName iter $ case cst of
Const -> "getConst"
Nonconst -> "get"
iterPrev <- toHsClassEntityName iter "prev"
saysLn ["empty' <- ", listEmpty, " this'"]
sayLn "if empty' then HoppyP.return [] else do"
indent $ do
saysLn ["begin' <- ", listBegin, " this'"]
saysLn ["iter' <- ", listEnd, " 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 =<< ",
iterGet, " iter'"]
sayLn "go' iter' begin' $ value':acc'"
when (cst == Nonconst) $ do
ln
saysLn ["instance HoppyFHR.FromContents ", hsDataTypeName,
" (", prettyPrint hsValueType, ") where"]
indent $ do
sayLn "fromContents values' = do"
indent $ do
listNew <- toHsClassEntityName list "new"
listPushBack <- toHsClassEntityName list "pushBack"
saysLn ["list' <- ", listNew]
saysLn ["HoppyP.mapM_ (", listPushBack, " list') values'"]
sayLn "HoppyP.return list'"
in Contents
{ c_list = list
, c_iterator = iterator
, c_constIterator = constIterator
}
toExports :: Contents -> [Export]
toExports m = map (ExportClass . ($ m)) [c_list, c_iterator, c_constIterator]