-- XXX: deactivate orphan instance warning as we're defining a few Storable
-- instances here. It's not worth fixing as I [aspiwack] intend to change the
-- interface for something more appropriate, which won't require these Storable
-- instances.
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

module Foreign.Marshal.Pure.Internal where

import Control.Exception
import qualified Data.Functor.Linear as Data
import Data.Kind (Constraint, Type)
import Data.Word (Word8)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Foreign.Storable.Tuple ()
import Prelude.Linear hiding (Eq (..), ($))
import System.IO.Unsafe
import qualified Unsafe.Linear as Unsafe
import Prelude (Eq (..), return, ($), (<$>), (<*>), (=<<))

-- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems
-- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not
-- the one that was released with 8.2, and that `mtl` fails to compile against
-- it), therefore, I'm redefining `Dict` here, as it's cheap.
data Dict :: Constraint -> Type where
  Dict :: (c) => Dict c

-- TODO: organise into sections

-- | This abstract type class represents values natively known to have a GC-less
-- implementation. Basically, these are sequences (represented as tuples) of
-- base types.
class KnownRepresentable a where
  storable :: Dict (Storable a)
  default storable :: (Storable a) => Dict (Storable a)
  storable = forall (c :: Constraint). c => Dict c
Dict

-- This ought to be read a `newtype` around `Storable`. This type is abstract,
-- because using Storable this way is highly unsafe: Storable uses IO so we
-- will call unsafePerformIO, and Storable doesn't guarantee linearity. But
-- Storable comes with a lot of machinery, in particular for
-- architecture-independent alignment. So we can depend on it.
--
-- So, we restrict ourselves to known instances that we trust. For base types
-- there is no reason to expect problems. Tuples are a bit more subtle in that
-- they use non-linear operations. But the way they are used should be ok. At
-- any rate: in case a bug is found, the tuple instances are a good place to
-- look.

instance KnownRepresentable Word -- TODO: more word types

instance KnownRepresentable Int

instance KnownRepresentable (Ptr a)

instance KnownRepresentable ()

instance
  (KnownRepresentable a, KnownRepresentable b) =>
  KnownRepresentable (a, b)
  where
  storable :: Dict (Storable (a, b))
storable =
    case (forall a. KnownRepresentable a => Dict (Storable a)
storable @a, forall a. KnownRepresentable a => Dict (Storable a)
storable @b) of
      (Dict (Storable a)
Dict, Dict (Storable b)
Dict) -> forall (c :: Constraint). c => Dict c
Dict

instance
  (KnownRepresentable a, KnownRepresentable b, KnownRepresentable c) =>
  KnownRepresentable (a, b, c)
  where
  storable :: Dict (Storable (a, b, c))
storable =
    case (forall a. KnownRepresentable a => Dict (Storable a)
storable @a, forall a. KnownRepresentable a => Dict (Storable a)
storable @b, forall a. KnownRepresentable a => Dict (Storable a)
storable @c) of
      (Dict (Storable a)
Dict, Dict (Storable b)
Dict, Dict (Storable c)
Dict) -> forall (c :: Constraint). c => Dict c
Dict

-- TODO: move to the definition of Ur
instance (Storable a) => Storable (Ur a) where
  sizeOf :: Ur a -> Int
sizeOf Ur a
_ = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)
  alignment :: Ur a -> Int
alignment Ur a
_ = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: a)
  peek :: Ptr (Ur a) -> IO (Ur a)
peek Ptr (Ur a)
ptr = forall a. a -> Ur a
Ur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr (Ur a)
ptr :: Ptr a)
  poke :: Ptr (Ur a) -> Ur a -> IO ()
poke Ptr (Ur a)
ptr (Ur a
a) = forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr (Ur a)
ptr :: Ptr a) a
a

instance (KnownRepresentable a) => KnownRepresentable (Ur a) where
  storable :: Dict (Storable (Ur a))
storable | Dict (Storable a)
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @a = forall (c :: Constraint). c => Dict c
Dict

-- Below is a KnownRepresentable instance for Maybe. The Storable instance is
-- taken from
-- https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe
--
-- aspiwack: This does not yield very good data representation for the general
-- case. But I believe that to improve on it we need to rethink the abstraction
-- in more depths.

instance (Storable a) => Storable (Maybe a) where
  sizeOf :: Maybe a -> Int
sizeOf Maybe a
x = forall a. Storable a => a -> Int
sizeOf (forall a. Maybe a -> a
stripMaybe Maybe a
x) forall a. Additive a => a %1 -> a %1 -> a
+ Int
1
  alignment :: Maybe a -> Int
alignment Maybe a
x = forall a. Storable a => a -> Int
alignment (forall a. Maybe a -> a
stripMaybe Maybe a
x)
  peek :: Ptr (Maybe a) -> IO (Maybe a)
peek Ptr (Maybe a)
ptr = do
    Word8
filled <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Maybe a)
ptr forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
sizeOf forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> a
stripMaybe forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> a
stripPtr Ptr (Maybe a)
ptr
    case Word8
filled forall a. Eq a => a -> a -> Bool
== (Word8
1 :: Word8) of
      Bool
True -> do
        a
x <- forall a. Storable a => Ptr a -> IO a
peek (forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr Ptr (Maybe a)
ptr)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
      Bool
False ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  poke :: Ptr (Maybe a) -> Maybe a -> IO ()
poke Ptr (Maybe a)
ptr Maybe a
Nothing = forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Maybe a)
ptr (forall a. Storable a => a -> Int
sizeOf forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> a
stripMaybe forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> a
stripPtr Ptr (Maybe a)
ptr) (Word8
0 :: Word8)
  poke Ptr (Maybe a)
ptr (Just a
a) = do
    forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr Ptr (Maybe a)
ptr) a
a
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Maybe a)
ptr (forall a. Storable a => a -> Int
sizeOf a
a) (Word8
1 :: Word8)

stripMaybe :: Maybe a -> a
stripMaybe :: forall a. Maybe a -> a
stripMaybe Maybe a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"stripMaybe"

stripMaybePtr :: Ptr (Maybe a) -> Ptr a
stripMaybePtr :: forall a. Ptr (Maybe a) -> Ptr a
stripMaybePtr = forall a b. Ptr a -> Ptr b
castPtr

stripPtr :: Ptr a -> a
stripPtr :: forall a. Ptr a -> a
stripPtr Ptr a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"stripPtr"

instance (KnownRepresentable a) => KnownRepresentable (Maybe a) where
  storable :: Dict (Storable (Maybe a))
storable | Dict (Storable a)
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @a = forall (c :: Constraint). c => Dict c
Dict

-- | Laws of 'Representable':
--
-- * 'toKnown' must be total
-- * 'ofKnown' may be partial, but must be total on the image of 'toKnown'
-- * @ofKnown . toKnown == id@
class (KnownRepresentable (AsKnown a)) => Representable a where
  type AsKnown a :: Type

  toKnown :: a %1 -> AsKnown a
  ofKnown :: AsKnown a %1 -> a

  default toKnown ::
    (MkRepresentable a b, AsKnown a ~ AsKnown b) => a %1 -> AsKnown a
  default ofKnown ::
    (MkRepresentable a b, AsKnown a ~ AsKnown b) => AsKnown a %1 -> a

  toKnown a
a = forall a. Representable a => a %1 -> AsKnown a
toKnown (forall a b. MkRepresentable a b => a %1 -> b
toRepr a
a)
  ofKnown AsKnown a
b = forall a b. MkRepresentable a b => b %1 -> a
ofRepr (forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
b)

-- Some boilerplate: all the KnownRepresentable are Representable, by virtue of
-- the identity being a retraction. We generalise a bit for the types of tuples:
-- tuples of Representable (not only KnownRepresentable) are Representable.
instance Representable Word where
  type AsKnown Word = Word
  toKnown :: Word %1 -> AsKnown Word
toKnown = forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown Word %1 -> Word
ofKnown = forall a (q :: Multiplicity). a %q -> a
id

instance Representable Int where
  type AsKnown Int = Int
  toKnown :: Int %1 -> AsKnown Int
toKnown = forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown Int %1 -> Int
ofKnown = forall a (q :: Multiplicity). a %q -> a
id

instance Representable (Ptr a) where
  type AsKnown (Ptr a) = Ptr a
  toKnown :: Ptr a %1 -> AsKnown (Ptr a)
toKnown = forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown (Ptr a) %1 -> Ptr a
ofKnown = forall a (q :: Multiplicity). a %q -> a
id

instance Representable () where
  type AsKnown () = ()
  toKnown :: () %1 -> AsKnown ()
toKnown = forall a (q :: Multiplicity). a %q -> a
id
  ofKnown :: AsKnown () %1 -> ()
ofKnown = forall a (q :: Multiplicity). a %q -> a
id

instance
  (Representable a, Representable b) =>
  Representable (a, b)
  where
  type AsKnown (a, b) = (AsKnown a, AsKnown b)
  toKnown :: (a, b) %1 -> AsKnown (a, b)
toKnown (a
a, b
b) = (forall a. Representable a => a %1 -> AsKnown a
toKnown a
a, forall a. Representable a => a %1 -> AsKnown a
toKnown b
b)
  ofKnown :: AsKnown (a, b) %1 -> (a, b)
ofKnown (AsKnown a
x, AsKnown b
y) = (forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x, forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown b
y)

instance
  (Representable a, Representable b, Representable c) =>
  Representable (a, b, c)
  where
  type AsKnown (a, b, c) = (AsKnown a, AsKnown b, AsKnown c)
  toKnown :: (a, b, c) %1 -> AsKnown (a, b, c)
toKnown (a
a, b
b, c
c) = (forall a. Representable a => a %1 -> AsKnown a
toKnown a
a, forall a. Representable a => a %1 -> AsKnown a
toKnown b
b, forall a. Representable a => a %1 -> AsKnown a
toKnown c
c)
  ofKnown :: AsKnown (a, b, c) %1 -> (a, b, c)
ofKnown (AsKnown a
x, AsKnown b
y, AsKnown c
z) = (forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x, forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown b
y, forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown c
z)

instance (Representable a) => Representable (Maybe a) where
  type AsKnown (Maybe a) = Maybe (AsKnown a)
  toKnown :: Maybe a %1 -> AsKnown (Maybe a)
toKnown (Just a
x) = forall a. a -> Maybe a
Just (forall a. Representable a => a %1 -> AsKnown a
toKnown a
x)
  toKnown Maybe a
Nothing = forall a. Maybe a
Nothing
  ofKnown :: AsKnown (Maybe a) %1 -> Maybe a
ofKnown (Just AsKnown a
x) = forall a. a -> Maybe a
Just (forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
x)
  ofKnown Maybe (AsKnown a)
AsKnown (Maybe a)
Nothing = forall a. Maybe a
Nothing

-- | This is an easier way to create an instance of 'Representable'. It is a bit
-- abusive to use a type class for this (after all, it almost never makes sense
-- to use this as a constraint). But it works in practice.
--
-- To use, define an instance of @MkRepresentable <myType> <intermediateType>@
-- then declare the following instance:
--
-- @instance Representable <myType> where {type AsKnown = AsKnown <intermediateType>}@
--
-- And the default instance mechanism will create the appropriate
-- 'Representable' instance.
--
-- Laws of 'MkRepresentable':
--
-- * 'toRepr' must be total
-- * 'ofRepr' may be partial, but must be total on the image of 'toRepr'
-- * @ofRepr . toRepr = id@
class (Representable b) => MkRepresentable a b | a -> b where
  toRepr :: a %1 -> b
  ofRepr :: b %1 -> a

-- TODO: Briefly explain the Dupable-reader style of API, below, and fix
-- details.

-- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This
-- is a no-op: it does not deallocate the data in that pool. It cannot do so,
-- because accessible values might still exist. Consuming a pool simply makes it
-- impossible to add new data to the pool.
data Pool where
  Pool :: DLL (Ptr ()) -> Pool

-- /!\ Black magic: the pointers in the pool are only used to deallocate
-- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler
-- to cast all the pointers to some canonical type (here `Ptr ()`) so that we
-- don't have to deal with heterogeneous types. /!\

-- Implementing a doubly-linked list with `Ptr`

data DLL a = DLL {forall a. DLL a -> Ptr (DLL a)
prev :: Ptr (DLL a), forall a. DLL a -> Ptr a
elt :: Ptr a, forall a. DLL a -> Ptr (DLL a)
next :: Ptr (DLL a)}
  deriving (DLL a -> DLL a -> Bool
forall a. DLL a -> DLL a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DLL a -> DLL a -> Bool
$c/= :: forall a. DLL a -> DLL a -> Bool
== :: DLL a -> DLL a -> Bool
$c== :: forall a. DLL a -> DLL a -> Bool
Eq)

-- XXX: probably replaceable by storable-generic
instance Storable (DLL a) where
  sizeOf :: DLL a -> Int
sizeOf DLL a
_ = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))
  alignment :: DLL a -> Int
alignment DLL a
_ = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))

  peek :: Ptr (DLL a) -> IO (DLL a)
peek Ptr (DLL a)
ptr = do
    (Ptr (DLL a)
p, Ptr a
e, Ptr (DLL a)
n) <- forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr (DLL a)
ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a)))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL Ptr (DLL a)
p Ptr a
e Ptr (DLL a)
n

  poke :: Ptr (DLL a) -> DLL a -> IO ()
poke Ptr (DLL a)
ptr (DLL Ptr (DLL a)
p Ptr a
e Ptr (DLL a)
n) =
    forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr (DLL a)
ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (Ptr (DLL a)
p, Ptr a
e, Ptr (DLL a)
n)

-- Precondition: in `insertAfter start ptr`, `next start` must be initalised,
-- and so must be `prev =<< peek (next start)`
insertAfter :: (Storable a) => DLL a -> a -> IO (Ptr (DLL a))
insertAfter :: forall a. Storable a => DLL a -> a -> IO (Ptr (DLL a))
insertAfter DLL a
start a
ptr = do
  DLL a
secondLink <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a. DLL a -> Ptr (DLL a)
next DLL a
start
  DLL a
newLink <- forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => a -> IO (Ptr a)
new DLL a
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => a -> IO (Ptr a)
new a
ptr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => a -> IO (Ptr a)
new DLL a
secondLink
  forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. DLL a -> Ptr (DLL a)
next DLL a
start) DLL a
newLink
  forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. DLL a -> Ptr (DLL a)
prev DLL a
secondLink) DLL a
newLink
  forall a. Storable a => a -> IO (Ptr a)
new DLL a
newLink

delete :: DLL a -> IO ()
delete :: forall a. DLL a -> IO ()
delete DLL a
link = do
  DLL a
prevLink <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a. DLL a -> Ptr (DLL a)
prev DLL a
link
  DLL a
nextLink <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a. DLL a -> Ptr (DLL a)
next DLL a
link
  forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. DLL a -> Ptr (DLL a)
next DLL a
prevLink) DLL a
nextLink
  forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. DLL a -> Ptr (DLL a)
prev DLL a
nextLink) DLL a
prevLink

-- /Doubly-linked list

-- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@
-- doesn't have a pointer, and indeed terminates the list.
--
freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end = do
  DLL (Ptr ())
nextLink <- forall a. Storable a => Ptr a -> IO a
peek (forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
start)
  if DLL (Ptr ())
nextLink forall a. Eq a => a -> a -> Bool
== DLL (Ptr ())
end
    then do
      forall a. Ptr a -> IO ()
free (forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
start)
      forall a. Ptr a -> IO ()
free (forall a. DLL a -> Ptr (DLL a)
prev DLL (Ptr ())
end)
    else do
      forall a. DLL a -> IO ()
delete DLL (Ptr ())
nextLink
      forall a. Ptr a -> IO ()
free (forall a. DLL a -> Ptr (DLL a)
prev DLL (Ptr ())
nextLink)
      forall a. Ptr a -> IO ()
free (forall a. DLL a -> Ptr a
elt DLL (Ptr ())
nextLink)
      forall a. Ptr a -> IO ()
free (forall a. DLL a -> Ptr (DLL a)
next DLL (Ptr ())
nextLink)
      DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end

-- TODO: document individual functions

-- | Given a linear computation that manages memory, run that computation.
withPool :: (Pool %1 -> Ur b) %1 -> Ur b
withPool :: forall b. (Pool %1 -> Ur b) %1 -> Ur b
withPool Pool %1 -> Ur b
scope = forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear forall b. (Pool %1 -> Ur b) -> Ur b
performScope Pool %1 -> Ur b
scope
  where
    -- XXX: do ^ without `toLinear` by using linear IO

    performScope :: (Pool %1 -> Ur b) -> Ur b
    performScope :: forall b. (Pool %1 -> Ur b) -> Ur b
performScope Pool %1 -> Ur b
scope' = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
      -- Initialise the pool
      Ptr (DLL (Ptr ()))
backPtr <- forall a. Storable a => IO (Ptr a)
malloc
      let end :: DLL (Ptr ())
end = forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL Ptr (DLL (Ptr ()))
backPtr forall a. Ptr a
nullPtr forall a. Ptr a
nullPtr -- always at the end of the list
      DLL (Ptr ())
start <- forall a. Ptr (DLL a) -> Ptr a -> Ptr (DLL a) -> DLL a
DLL forall a. Ptr a
nullPtr forall a. Ptr a
nullPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => a -> IO (Ptr a)
new DLL (Ptr ())
end -- always at the start of the list
      forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (DLL (Ptr ()))
backPtr DLL (Ptr ())
start
      -- Run the computation
      forall a. a -> IO a
evaluate (Pool %1 -> Ur b
scope' (DLL (Ptr ()) -> Pool
Pool DLL (Ptr ())
start))
        forall a b. IO a -> IO b -> IO a
`finally`
        -- Clean up remaining variables.
        (DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()
freeAll DLL (Ptr ())
start DLL (Ptr ())
end)

instance Consumable Pool where
  consume :: Pool %1 -> ()
consume (Pool DLL (Ptr ())
_) = ()

instance Dupable Pool where
  dupR :: Pool %1 -> Replicator Pool
dupR (Pool DLL (Ptr ())
l) = forall (f :: * -> *) a. Applicative f => a -> f a
Data.pure (DLL (Ptr ()) -> Pool
Pool DLL (Ptr ())
l)

-- | 'Box a' is the abstract type of manually managed data. It can be used as
-- part of data type definitions in order to store linked data structure off
-- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of
-- the source repository.
data Box a where
  Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a

-- XXX: if Box is a newtype, can be derived
instance Storable (Box a) where
  sizeOf :: Box a -> Int
sizeOf Box a
_ = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: (Ptr (DLL (Ptr ())), Ptr a))
  alignment :: Box a -> Int
alignment Box a
_ = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: (Ptr (DLL (Ptr ())), Ptr a))
  peek :: Ptr (Box a) -> IO (Box a)
peek Ptr (Box a)
ptr = do
    (Ptr (DLL (Ptr ()))
pool, Ptr a
ptr') <- forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr (Box a)
ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a))
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ptr (DLL (Ptr ())) -> Ptr a -> Box a
Box Ptr (DLL (Ptr ()))
pool Ptr a
ptr')
  poke :: Ptr (Box a) -> Box a -> IO ()
poke Ptr (Box a)
ptr (Box Ptr (DLL (Ptr ()))
pool Ptr a
ptr') =
    forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr (Box a)
ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (Ptr (DLL (Ptr ()))
pool, Ptr a
ptr')

instance KnownRepresentable (Box a)

instance Representable (Box a) where
  type AsKnown (Box a) = Box a
  ofKnown :: AsKnown (Box a) %1 -> Box a
ofKnown = forall a (q :: Multiplicity). a %q -> a
id
  toKnown :: Box a %1 -> AsKnown (Box a)
toKnown = forall a (q :: Multiplicity). a %q -> a
id

-- TODO: a way to store GC'd data using a StablePtr

-- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not
-- Movable. In order to be useful, need some kind of borrowing on the values, I
-- guess. 'Box' can be realloced, but not RC pointers.

reprPoke :: forall a. (Representable a) => Ptr a -> a %1 -> IO ()
reprPoke :: forall a. Representable a => Ptr a -> a %1 -> IO ()
reprPoke Ptr a
ptr a
a
  | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) =
      forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr (AsKnown a))) (forall a. Representable a => a %1 -> AsKnown a
toKnown a
a)

reprNew :: forall a. (Representable a) => a %1 -> IO (Ptr a)
reprNew :: forall a. Representable a => a %1 -> IO (Ptr a)
reprNew a
a =
  forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear a -> IO (Ptr a)
mkPtr a
a
  where
    -- XXX: should be improved by using linear IO
    mkPtr :: a -> IO (Ptr a)
    mkPtr :: a -> IO (Ptr a)
mkPtr a
a' | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) =
      do
        Ptr (AsKnown a)
ptr0 <- forall a. Storable a => IO (Ptr a)
malloc @(AsKnown a)
        let ptr :: Ptr a
ptr = forall a b. Ptr a -> Ptr b
castPtr Ptr (AsKnown a)
ptr0 :: Ptr a
        forall a. Representable a => Ptr a -> a %1 -> IO ()
reprPoke Ptr a
ptr a
a'
        forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

-- TODO: Ideally, we would like to avoid having a boxed representation of the
-- data before a pointer is created. A better solution is to have a destination
-- passing-style API (but there is still some design to be done there). This
-- alloc primitive would then be derived (but most of the time we would rather
-- write bespoke constructors).

-- | Store a value @a@ on the system heap that is not managed by the GC.
alloc :: forall a. (Representable a) => a %1 -> Pool %1 -> Box a
alloc :: forall a. Representable a => a %1 -> Pool %1 -> Box a
alloc a
a (Pool DLL (Ptr ())
pool) =
  forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear a -> Box a
mkPtr a
a
  where
    -- XXX: should be improved by using linear IO
    mkPtr :: a -> Box a
    mkPtr :: a -> Box a
mkPtr a
a' = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
      Ptr a
ptr <- forall a. Representable a => a %1 -> IO (Ptr a)
reprNew a
a'
      Ptr (DLL (Ptr ()))
poolPtr <- forall a. Storable a => DLL a -> a -> IO (Ptr (DLL a))
insertAfter DLL (Ptr ())
pool (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr ())
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ptr (DLL (Ptr ())) -> Ptr a -> Box a
Box Ptr (DLL (Ptr ()))
poolPtr Ptr a
ptr)

-- TODO: would be better in linear IO, for we pretend that we are making an
-- unrestricted 'a', where really we are not.
reprPeek :: forall a. (Representable a) => Ptr a -> IO a
reprPeek :: forall a. Representable a => Ptr a -> IO a
reprPeek Ptr a
ptr | Dict (Storable (AsKnown a))
Dict <- forall a. KnownRepresentable a => Dict (Storable a)
storable @(AsKnown a) = do
  AsKnown a
knownRepr <- forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr :: Ptr (AsKnown a))
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Representable a => AsKnown a %1 -> a
ofKnown AsKnown a
knownRepr)

-- | Retrieve the value stored on system heap memory.
deconstruct :: (Representable a) => Box a %1 -> a
deconstruct :: forall a. Representable a => Box a %1 -> a
deconstruct (Box Ptr (DLL (Ptr ()))
poolPtr Ptr a
ptr) = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
  forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    a
res <- forall a. Representable a => Ptr a -> IO a
reprPeek Ptr a
ptr
    forall a. DLL a -> IO ()
delete forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr (DLL (Ptr ()))
poolPtr
    forall a. Ptr a -> IO ()
free Ptr a
ptr
    forall a. Ptr a -> IO ()
free Ptr (DLL (Ptr ()))
poolPtr
    forall (m :: * -> *) a. Monad m => a -> m a
return a
res