{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}

-- | @std::set@
module Hercules.CNix.Std.Set
  ( stdSetCtx,
    instanceStdSet,
    instanceStdSetCopyable,
    CStdSet,
    StdSet (StdSet),
    Hercules.CNix.Std.Set.new,
    size,
    toSet,
    fromList,
    fromListP,
    fromListFP,
    Hercules.CNix.Std.Set.toList,
    insert,
    insertP,
    insertFP,
    toListFP,
  )
where

import Control.Exception (mask_)
import Data.Coerce (Coercible, coerce)
import Data.Foldable (for_)
import qualified Data.Set as S
import Data.Traversable (for)
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as VSM
import Foreign
  ( ForeignPtr,
    FunPtr,
    Ptr,
    Storable,
    newForeignPtr,
    withForeignPtr,
  )
import Foreign.C (CSize)
import Hercules.CNix.Encapsulation (HasEncapsulation (..))
import qualified Language.C.Inline as C
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Unsafe as CU
import Language.Haskell.TH (DecsQ)
import Language.Haskell.TH.Syntax (Dec, Q)
import Prelude

data CStdSet a

stdSetCtx :: C.Context
stdSetCtx :: Context
stdSetCtx = Context
C.cppCtx Context -> Context -> Context
forall a. Monoid a => a -> a -> a
`mappend` [(CIdentifier, TypeQ)] -> Context
C.cppTypePairs [(CIdentifier
"std::set", [t|CStdSet|])]

newtype StdSet a = StdSet (ForeignPtr (CStdSet a))

instance (HasStdSet a) => HasEncapsulation (CStdSet a) (StdSet a) where
  moveToForeignPtrWrapper :: Ptr (CStdSet a) -> IO (StdSet a)
moveToForeignPtrWrapper = (ForeignPtr (CStdSet a) -> StdSet a)
-> IO (ForeignPtr (CStdSet a)) -> IO (StdSet a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (CStdSet a) -> StdSet a
forall a. ForeignPtr (CStdSet a) -> StdSet a
StdSet (IO (ForeignPtr (CStdSet a)) -> IO (StdSet a))
-> (Ptr (CStdSet a) -> IO (ForeignPtr (CStdSet a)))
-> Ptr (CStdSet a)
-> IO (StdSet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizerPtr (CStdSet a)
-> Ptr (CStdSet a) -> IO (ForeignPtr (CStdSet a))
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr (CStdSet a)
forall a. HasStdSet a => FunPtr (Ptr (CStdSet a) -> IO ())
cDelete

class HasStdSet a where
  cNew :: IO (Ptr (CStdSet a))
  cDelete :: FunPtr (Ptr (CStdSet a) -> IO ())
  cSize :: Ptr (CStdSet a) -> IO CSize
  cInsertByPtr :: Ptr a -> Ptr (CStdSet a) -> IO ()
  cCopies :: Ptr (CStdSet a) -> Ptr (Ptr a) -> IO ()

class (HasStdSet a) => HasStdSetCopyable a where
  cCopyTo :: Ptr (CStdSet a) -> Ptr a -> IO ()
  cInsert :: a -> Ptr (CStdSet a) -> IO ()

-- | Helper for defining templated instances
roll :: String -> Q [Dec] -> Q [Dec]
roll :: [Char] -> Q [Dec] -> Q [Dec]
roll [Char]
cType Q [Dec]
d =
  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ [Char] -> Q [Dec]
C.include [Char]
"<set>",
        [Char] -> Q [Dec]
C.include [Char]
"<algorithm>",
        [([Char], [Char] -> [Char])] -> Q [Dec] -> Q [Dec]
forall a. [([Char], [Char] -> [Char])] -> Q a -> Q a
C.substitute
          [ ([Char]
"T", [Char] -> [Char] -> [Char]
forall a b. a -> b -> a
const [Char]
cType),
            ([Char]
"SET", \[Char]
var -> [Char]
"$(std::set<" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cType [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">* " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
var [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
          ]
          Q [Dec]
d
      ]

instanceStdSet :: String -> DecsQ
instanceStdSet :: [Char] -> Q [Dec]
instanceStdSet [Char]
cType =
  [Char] -> Q [Dec] -> Q [Dec]
roll
    [Char]
cType
    [d|
      instance HasStdSet $(Bool -> [Char] -> TypeQ
C.getHaskellType Bool
False [Char]
cType) where
        cNew = [CU.exp| std::set<@T()>* { new std::set<@T()>() } |]
        cDelete = [C.funPtr| void deleteStdSet(std::set<@T()>* set) { delete set; } |]
        cSize set = [CU.exp| size_t { @SET(set)->size() } |]
        cInsertByPtr ptr set = [CU.exp| void { @SET(set)->insert(*$(@T() *ptr)) } |]
        cCopies set dstPtr =
          [CU.block| void {
            const std::set<@T()>& set = *@SET(set);
            @T()** aim = $(@T()** dstPtr);
            for (auto item : set) {
              *aim = new @T()(item);
              aim++;
            }
          }|]
      |]

instanceStdSetCopyable :: String -> DecsQ
instanceStdSetCopyable :: [Char] -> Q [Dec]
instanceStdSetCopyable [Char]
cType =
  [Char] -> Q [Dec] -> Q [Dec]
roll
    [Char]
cType
    [d|
      instance HasStdSetCopyable $(Bool -> [Char] -> TypeQ
C.getHaskellType Bool
False [Char]
cType) where
        cCopyTo set dstPtr =
          [CU.block| void {
            const std::set<@T()>* set = @SET(set);
            std::copy(set->begin(), set->end(), $(@T()* dstPtr));
            } |]
        cInsert value set =
          [CU.exp| void { @SET(set)->insert($(@T() value)) }
        |]
      |]

new :: forall a. (HasStdSet a) => IO (StdSet a)
new :: forall a. HasStdSet a => IO (StdSet a)
new = IO (StdSet a) -> IO (StdSet a)
forall a. IO a -> IO a
mask_ (IO (StdSet a) -> IO (StdSet a)) -> IO (StdSet a) -> IO (StdSet a)
forall a b. (a -> b) -> a -> b
$ do
  Ptr (CStdSet a) -> IO (StdSet a)
forall a b. HasEncapsulation a b => Ptr a -> IO b
moveToForeignPtrWrapper (Ptr (CStdSet a) -> IO (StdSet a))
-> IO (Ptr (CStdSet a)) -> IO (StdSet a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. HasStdSet a => IO (Ptr (CStdSet a))
cNew @a

size :: (HasStdSet a) => StdSet a -> IO Int
size :: forall a. HasStdSet a => StdSet a -> IO Int
size (StdSet ForeignPtr (CStdSet a)
fptr) = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO CSize) -> IO CSize
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
fptr Ptr (CStdSet a) -> IO CSize
forall a. HasStdSet a => Ptr (CStdSet a) -> IO CSize
cSize

fromList :: (HasStdSetCopyable a) => [a] -> IO (StdSet a)
fromList :: forall a. HasStdSetCopyable a => [a] -> IO (StdSet a)
fromList [a]
as = do
  StdSet a
set <- IO (StdSet a)
forall a. HasStdSet a => IO (StdSet a)
new
  [a] -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [a]
as ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ StdSet a -> a -> IO ()
forall a. HasStdSetCopyable a => StdSet a -> a -> IO ()
insert StdSet a
set
  StdSet a -> IO (StdSet a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdSet a
set

fromListP :: (HasStdSet a) => [Ptr a] -> IO (StdSet a)
fromListP :: forall a. HasStdSet a => [Ptr a] -> IO (StdSet a)
fromListP [Ptr a]
as = do
  StdSet a
set <- IO (StdSet a)
forall a. HasStdSet a => IO (StdSet a)
new
  [Ptr a] -> (Ptr a -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Ptr a]
as ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ StdSet a -> Ptr a -> IO ()
forall a. HasStdSet a => StdSet a -> Ptr a -> IO ()
insertP StdSet a
set
  StdSet a -> IO (StdSet a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdSet a
set

fromListFP :: (Coercible a' (ForeignPtr a), HasStdSet a) => [a'] -> IO (StdSet a)
fromListFP :: forall a' a.
(Coercible a' (ForeignPtr a), HasStdSet a) =>
[a'] -> IO (StdSet a)
fromListFP [a']
as = do
  StdSet a
set <- IO (StdSet a)
forall a. HasStdSet a => IO (StdSet a)
new
  [a'] -> (a' -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [a']
as ((a' -> IO ()) -> IO ()) -> (a' -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ StdSet a -> a' -> IO ()
forall a' a.
(Coercible a' (ForeignPtr a), HasStdSet a) =>
StdSet a -> a' -> IO ()
insertFP StdSet a
set
  StdSet a -> IO (StdSet a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdSet a
set

toSet :: (HasStdSetCopyable a, Storable a, Ord a) => StdSet a -> IO (S.Set a)
toSet :: forall a.
(HasStdSetCopyable a, Storable a, Ord a) =>
StdSet a -> IO (Set a)
toSet StdSet a
stdSet = do
  [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> (Vector a -> [a]) -> Vector a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Storable a => Vector a -> [a]
VS.toList (Vector a -> Set a) -> IO (Vector a) -> IO (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdSet a -> IO (Vector a)
forall a.
(HasStdSetCopyable a, Storable a) =>
StdSet a -> IO (Vector a)
toVector StdSet a
stdSet

toVector :: (HasStdSetCopyable a, Storable a) => StdSet a -> IO (VS.Vector a)
toVector :: forall a.
(HasStdSetCopyable a, Storable a) =>
StdSet a -> IO (Vector a)
toVector stdSet :: StdSet a
stdSet@(StdSet ForeignPtr (CStdSet a)
stdSetFPtr) = do
  Int
vecSize <- StdSet a -> IO Int
forall a. HasStdSet a => StdSet a -> IO Int
size StdSet a
stdSet
  IOVector a
hsVec <- Int -> IO (MVector (PrimState IO) a)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
VSM.new Int
vecSize
  ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
stdSetFPtr ((Ptr (CStdSet a) -> IO ()) -> IO ())
-> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (CStdSet a)
stdSetPtr ->
    IOVector a -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => IOVector a -> (Ptr a -> IO b) -> IO b
VSM.unsafeWith IOVector a
hsVec ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
hsVecPtr ->
      Ptr (CStdSet a) -> Ptr a -> IO ()
forall a. HasStdSetCopyable a => Ptr (CStdSet a) -> Ptr a -> IO ()
cCopyTo Ptr (CStdSet a)
stdSetPtr Ptr a
hsVecPtr
  MVector (PrimState IO) a -> IO (Vector a)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze IOVector a
MVector (PrimState IO) a
hsVec

toList :: (HasStdSetCopyable a, Storable a) => StdSet a -> IO [a]
toList :: forall a. (HasStdSetCopyable a, Storable a) => StdSet a -> IO [a]
toList StdSet a
vec = Vector a -> [a]
forall a. Storable a => Vector a -> [a]
VS.toList (Vector a -> [a]) -> IO (Vector a) -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdSet a -> IO (Vector a)
forall a.
(HasStdSetCopyable a, Storable a) =>
StdSet a -> IO (Vector a)
toVector StdSet a
vec

toVectorP :: (HasStdSet a) => StdSet a -> IO (VS.Vector (Ptr a))
toVectorP :: forall a. HasStdSet a => StdSet a -> IO (Vector (Ptr a))
toVectorP stdSet :: StdSet a
stdSet@(StdSet ForeignPtr (CStdSet a)
stdSetFPtr) = do
  Int
vecSize <- StdSet a -> IO Int
forall a. HasStdSet a => StdSet a -> IO Int
size StdSet a
stdSet
  IOVector (Ptr a)
hsVec <- Int -> IO (MVector (PrimState IO) (Ptr a))
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
VSM.new Int
vecSize
  ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
stdSetFPtr ((Ptr (CStdSet a) -> IO ()) -> IO ())
-> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (CStdSet a)
stdSetPtr ->
    IOVector (Ptr a) -> (Ptr (Ptr a) -> IO ()) -> IO ()
forall a b. Storable a => IOVector a -> (Ptr a -> IO b) -> IO b
VSM.unsafeWith IOVector (Ptr a)
hsVec ((Ptr (Ptr a) -> IO ()) -> IO ())
-> (Ptr (Ptr a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr a)
hsVecPtr ->
      Ptr (CStdSet a) -> Ptr (Ptr a) -> IO ()
forall a. HasStdSet a => Ptr (CStdSet a) -> Ptr (Ptr a) -> IO ()
cCopies Ptr (CStdSet a)
stdSetPtr Ptr (Ptr a)
hsVecPtr
  MVector (PrimState IO) (Ptr a) -> IO (Vector (Ptr a))
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze IOVector (Ptr a)
MVector (PrimState IO) (Ptr a)
hsVec

toListP :: (HasStdSet a) => StdSet a -> IO [Ptr a]
toListP :: forall a. HasStdSet a => StdSet a -> IO [Ptr a]
toListP StdSet a
vec = Vector (Ptr a) -> [Ptr a]
forall a. Storable a => Vector a -> [a]
VS.toList (Vector (Ptr a) -> [Ptr a]) -> IO (Vector (Ptr a)) -> IO [Ptr a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdSet a -> IO (Vector (Ptr a))
forall a. HasStdSet a => StdSet a -> IO (Vector (Ptr a))
toVectorP StdSet a
vec

toListFP :: (HasStdSet a, HasEncapsulation a b) => StdSet a -> IO [b]
toListFP :: forall a b.
(HasStdSet a, HasEncapsulation a b) =>
StdSet a -> IO [b]
toListFP StdSet a
vec = IO [b] -> IO [b]
forall a. IO a -> IO a
mask_ (IO [b] -> IO [b]) -> IO [b] -> IO [b]
forall a b. (a -> b) -> a -> b
$ do
  [Ptr a]
ptrs <- StdSet a -> IO [Ptr a]
forall a. HasStdSet a => StdSet a -> IO [Ptr a]
toListP StdSet a
vec
  [Ptr a] -> (Ptr a -> IO b) -> IO [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Ptr a]
ptrs Ptr a -> IO b
forall a b. HasEncapsulation a b => Ptr a -> IO b
moveToForeignPtrWrapper

insert :: (HasStdSetCopyable a) => StdSet a -> a -> IO ()
insert :: forall a. HasStdSetCopyable a => StdSet a -> a -> IO ()
insert (StdSet ForeignPtr (CStdSet a)
fptr) a
value = ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
fptr (a -> Ptr (CStdSet a) -> IO ()
forall a. HasStdSetCopyable a => a -> Ptr (CStdSet a) -> IO ()
cInsert a
value)

insertP :: (HasStdSet a) => StdSet a -> Ptr a -> IO ()
insertP :: forall a. HasStdSet a => StdSet a -> Ptr a -> IO ()
insertP (StdSet ForeignPtr (CStdSet a)
fptr) Ptr a
ptr = ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
fptr (Ptr a -> Ptr (CStdSet a) -> IO ()
forall a. HasStdSet a => Ptr a -> Ptr (CStdSet a) -> IO ()
cInsertByPtr Ptr a
ptr)

insertFP :: (Coercible a' (ForeignPtr a), HasStdSet a) => StdSet a -> a' -> IO ()
insertFP :: forall a' a.
(Coercible a' (ForeignPtr a), HasStdSet a) =>
StdSet a -> a' -> IO ()
insertFP (StdSet ForeignPtr (CStdSet a)
fptr) a'
vfptr =
  ForeignPtr (CStdSet a) -> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (CStdSet a)
fptr ((Ptr (CStdSet a) -> IO ()) -> IO ())
-> (Ptr (CStdSet a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (CStdSet a)
setPtr ->
    ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (a' -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce a'
vfptr) (\Ptr a
valPtr -> Ptr a -> Ptr (CStdSet a) -> IO ()
forall a. HasStdSet a => Ptr a -> Ptr (CStdSet a) -> IO ()
cInsertByPtr Ptr a
valPtr Ptr (CStdSet a)
setPtr)