{-# LANGUAGE CPP , UnicodeSyntax , NoImplicitPrelude , KindSignatures , RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Foreign.Ptr.Region.Internal -- Copyright : (c) 2010-2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- ------------------------------------------------------------------------------- module Foreign.Ptr.Region.Internal ( -- * Regional pointers RegionalPtr(RegionalPtr) , unsafeRegionalPtr , wrapMalloc -- * Null pointers , nullPtr, NullPtr -- * Foreign regional pointers , LocalPtr , wrapAlloca, wrapAlloca2 -- * Wrapping @CStringLen@ operations , wrapPeekStringLen , wrapNewStringLen , wrapWithStringLen -- * Unsafe utility functions for lifting operations on @Ptrs@ to @RegionalPtrs@ , Pointer(unsafePtr, mapPointer) , unsafeWrap, unsafeWrap2, unsafeWrap3 , unsafeWrap2flp -- * Pointers to allocated memory , AllocatedPointer ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Control.Monad ( return, liftM ) import Control.Arrow ( first ) import Data.Function ( ($), flip ) import Data.Int ( Int ) import System.IO ( IO ) import Foreign.Ptr ( Ptr ) import qualified Foreign.Ptr as FP ( nullPtr ) import Foreign.Marshal.Alloc ( free ) #if MIN_VERSION_base(4,4,0) import Data.String ( String ) #else import Data.Char ( String ) #endif #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) #endif -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) -- from transformers: import Control.Monad.IO.Class ( MonadIO, liftIO ) -- from regions: import Control.Monad.Trans.Region.OnExit ( FinalizerHandle, Finalizer, onExit ) import Control.Monad.Trans.Region ( RegionT , RegionControlIO , AncestorRegion , RootRegion , LocalRegion, Local , Dup(dup) ) import Control.Monad.Trans.Region.Unsafe ( unsafeStripLocal , unsafeControlIO , unsafeLiftIOOp , unsafeLiftIOOp_ ) #if MIN_VERSION_base(4,3,0) import Control.Exception ( mask_ ) #else import Control.Exception ( block ) mask_ ∷ IO a → IO a mask_ = block #endif -------------------------------------------------------------------------------- -- * Regional pointers -------------------------------------------------------------------------------- {-| A regional pointer to memory. This should provide a safer replacement for @Foreign.Ptr.'Ptr'@ -} data RegionalPtr α (r ∷ * → *) = RegionalPtr !(Ptr α) !(FinalizerHandle r) instance Dup (RegionalPtr α) where dup (RegionalPtr ptr ch) = liftM (RegionalPtr ptr) (dup ch) {-| Construct a regional pointer from a native pointer and an @IO@ computation that finalizes the pointer (like @free ptr@) which is performed when the region terminates. This function is unsafe because this library can't guarantee that the finalizer will actually finalize the pointer (suppose having @return ()@ as the finalizer). You have to verify the correct finalisation yourself. -} unsafeRegionalPtr ∷ MonadIO pr ⇒ Ptr α → Finalizer → RegionT s pr (RegionalPtr α (RegionT s pr)) unsafeRegionalPtr ptr finalize = liftM (RegionalPtr ptr) (onExit finalize) wrapMalloc ∷ RegionControlIO pr ⇒ IO (Ptr α) → RegionT s pr (RegionalPtr α (RegionT s pr)) wrapMalloc doMalloc = unsafeControlIO $ \runInIO → mask_ $ do ptr ← doMalloc runInIO $ unsafeRegionalPtr ptr (free ptr) -------------------------------------------------------------------------------- -- * Null pointers -------------------------------------------------------------------------------- {-| The constant @nullPtr@ is a pointer which is not associated with a valid memory location. Note that @nullPtr@ is a pure value. This means it does not perform the side-effect of registering a finalizer like \"@free nullPtr@\" in the 'RegionT' monad. Finally note that the region parameter of the 'NullPtr' is set to 'RootRegion' which is the ancestor of any region. This allows 'nullPtr' to be used in any region. -} nullPtr ∷ NullPtr α RootRegion nullPtr = NullPtr FP.nullPtr newtype NullPtr α (r ∷ * → *) = NullPtr (Ptr α) -------------------------------------------------------------------------------- -- * Foreign regional pointers -------------------------------------------------------------------------------- -- | A regional pointer to memory which was locally allocated -- by one of the @alloca@-like functions. -- -- Note that a @LocalPtr@ can not be 'dup'licated to a parent region. newtype LocalPtr α (r ∷ * → *) = LocalPtr (Ptr α) wrapAlloca ∷ RegionControlIO pr ⇒ ((Ptr α → IO (RegionT s pr β)) → IO (RegionT s pr β)) → (∀ sl. LocalPtr α (LocalRegion sl s) → RegionT (Local s) pr β) → RegionT s pr β wrapAlloca doAlloca f = unsafeLiftIOOp doAlloca $ unsafeStripLocal ∘ f ∘ LocalPtr wrapAlloca2 ∷ RegionControlIO pr ⇒ ((γ → Ptr α → IO (RegionT s pr β)) → IO (RegionT s pr β)) → (∀ sl. γ → LocalPtr α (LocalRegion sl s) → RegionT (Local s) pr β) → RegionT s pr β wrapAlloca2 doAlloca f = unsafeControlIO $ \runInIO → doAlloca $ \s → runInIO ∘ unsafeStripLocal ∘ f s ∘ LocalPtr -------------------------------------------------------------------------------- -- * Wrapping @CStringLen@ operations -------------------------------------------------------------------------------- wrapPeekStringLen ∷ (Pointer pointer, pr `AncestorRegion` cr, MonadIO cr) ⇒ ((Ptr α, Int) → IO String) → (pointer α pr, Int) → cr String wrapPeekStringLen peekStringLen = liftIO ∘ peekStringLen ∘ first unsafePtr wrapNewStringLen ∷ RegionControlIO pr ⇒ IO (Ptr α, Int) → RegionT s pr (RegionalPtr α (RegionT s pr), Int) wrapNewStringLen newStringLen = unsafeLiftIOOp_ mask_ $ do (ptr, len) ← liftIO newStringLen rPtr ← unsafeRegionalPtr ptr (free ptr) return (rPtr, len) wrapWithStringLen ∷ RegionControlIO pr ⇒ (((Ptr α, Int) → IO (RegionT s pr β)) → IO (RegionT s pr β)) → (∀ sl. (LocalPtr α (LocalRegion sl s), Int) → RegionT (Local s) pr β) → RegionT s pr β wrapWithStringLen withStringLen f = unsafeLiftIOOp withStringLen $ unsafeStripLocal ∘ f ∘ first LocalPtr -------------------------------------------------------------------------------- -- * Utility functions for lifting operations on Ptrs to RegionalPtrs -------------------------------------------------------------------------------- class Pointer (pointer ∷ * → (* → *) → *) where -- | Retrieve the native pointer from a regional pointer. -- -- This function is unsafe because it allows you to both @free@ the pointer -- before the region terminates and use the pointer outside the region when it -- is already freed. unsafePtr ∷ pointer α r → Ptr α -- | Apply a /pure/ function to the inner pointer of a regional pointer. mapPointer ∷ (Ptr α → Ptr β) → (pointer α r → pointer β r) instance Pointer RegionalPtr where unsafePtr (RegionalPtr ptr _) = ptr mapPointer f (RegionalPtr ptr ch) = RegionalPtr (f ptr) ch instance Pointer NullPtr where unsafePtr (NullPtr ptr) = ptr mapPointer f (NullPtr ptr) = NullPtr (f ptr) instance Pointer LocalPtr where unsafePtr (LocalPtr ptr) = ptr mapPointer f (LocalPtr ptr) = LocalPtr (f ptr) unsafeWrap ∷ (MonadIO m, Pointer pointer) ⇒ (Ptr α → IO β) → (pointer α r → m β) unsafeWrap f pointer = liftIO $ f (unsafePtr pointer) unsafeWrap2 ∷ (MonadIO m, Pointer pointer) ⇒ (Ptr α → γ → IO β) → (pointer α r → γ → m β) unsafeWrap2 f pointer x = liftIO $ f (unsafePtr pointer) x unsafeWrap3 ∷ (MonadIO m, Pointer pointer) ⇒ (Ptr α → γ → δ → IO β) → (pointer α r → γ → δ → m β) unsafeWrap3 f pointer x y = liftIO $ f (unsafePtr pointer) x y unsafeWrap2flp ∷ (MonadIO m, Pointer pointer) ⇒ (γ → Ptr α → IO β) → (γ → pointer α r → m β) unsafeWrap2flp = flip ∘ unsafeWrap2 ∘ flip -------------------------------------------------------------------------------- -- * Allocated pointers -------------------------------------------------------------------------------- class Pointer pointer ⇒ PrivateAllocatedPointer pointer -- | Class of pointers which point to allocated memory. 'NullPtr' is the only -- pointer which is not an instance of this class. -- -- The super class 'PrivateAllocatedPointer' is not exported by this module -- which ensures you can't accidentally make 'NullPtr' an instance of this class. class PrivateAllocatedPointer pointer ⇒ AllocatedPointer pointer instance PrivateAllocatedPointer RegionalPtr; instance AllocatedPointer RegionalPtr instance PrivateAllocatedPointer LocalPtr; instance AllocatedPointer LocalPtr -- The End ---------------------------------------------------------------------