diff --git a/Foreign/C/String/Region.hs b/Foreign/C/String/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/C/String/Region.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE UnicodeSyntax + , NoImplicitPrelude + , RankNTypes + , CPP + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.C.String.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- Lifts functions and types from @Foreign.C.String@ to regional pointers. +-- +------------------------------------------------------------------------------- + +module Foreign.C.String.Region + ( -- * Regional C Strings + RegionalCString, RegionalCStringLen + + -- * Using a locale-dependent encoding + , peekCString, peekCStringLen + , newCString, newCStringLen + , withCString, withCStringLen + + , charIsRepresentable + + -- * Using 8-bit characters + , FCS.castCharToCChar + , FCS.castCCharToChar + + , peekCAString, peekCAStringLen + , newCAString, newCAStringLen + , withCAString, withCAStringLen + + -- * C wide strings + , RegionalCWString, RegionalCWStringLen + , peekCWString, peekCWStringLen + , newCWString, newCWStringLen + , withCWString, withCWStringLen + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( fromInteger, fromIntegral ) +import Data.Function ( ($) ) +import Data.Bool ( Bool ) +import Data.Int ( Int ) +import Data.Char ( Char, String, ord ) +import Data.List ( map, length ) +import Control.Arrow ( first ) +import Control.Monad ( return, (>>=), fail) +import Foreign.C.Types ( CChar, CWchar ) +import Foreign.Storable ( Storable ) +import qualified Foreign.C.String as FCS ( charIsRepresentable + , peekCAString, peekCAStringLen + , peekCWString, peekCWStringLen + , castCharToCChar, castCCharToChar + ) + +#ifdef __HADDOCK__ +import Foreign.C.String ( CString, CStringLen + , CWString, CWStringLen + ) +#endif + +#ifdef mingw32_HOST_OS +-- These are only used in the mingw32 version of 'charsToCWchars': +import Prelude ( (-), (+), mod, div ) +import Data.List ( foldr ) +import Data.Bool ( otherwise ) +import Control.Monad ( (>>) ) +import Data.Ord ( (<) ) +#endif + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from transformers: +import Control.Monad.Trans ( MonadIO, liftIO ) + +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO ) + +-- from regions: +import Control.Monad.Trans.Region ( RegionT, ParentOf ) + +-- from ourselves: +import Foreign.Marshal.Array.Region ( newArray0, newArray + , withArray0, withArrayLen + ) +import Foreign.Ptr.Region ( RegionalPtr ) +import Foreign.Ptr.Region.Unsafe ( unsafePtr, unsafeWrap ) + + +-------------------------------------------------------------------------------- +-- Regional C Strings +-------------------------------------------------------------------------------- + +-- | Handy type synonym for a regional pointer to an array of C characters +-- terminated by a NUL. +-- +-- This should provide a safer replacement for @Foreign.C.String.'CString'@. +type RegionalCString r = RegionalPtr CChar r + +-- | Handy type synonym for a regional pointer to an array of C characters which +-- is paired with the length of the array instead of terminated by a NUL. +-- (Thus allowing NUL characters in the middle of the string) +-- +-- This should provide a safer replacement for @Foreign.C.String.'CStringLen'@. +type RegionalCStringLen r = (RegionalPtr CChar r, Int) + + +-------------------------------------------------------------------------------- +-- Using a locale-dependent encoding +-------------------------------------------------------------------------------- + +peekCString ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCString pr → cr String +peekCString = peekCAString + +peekCStringLen ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCStringLen pr → cr String +peekCStringLen = peekCAStringLen + +newCString ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCString (RegionT s pr)) +newCString = newCAString + +newCStringLen ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCStringLen (RegionT s pr)) +newCStringLen = newCAStringLen + +withCString ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCString (RegionT s pr) → RegionT s pr α) + → pr α +withCString = withCAString + +withCStringLen ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCStringLen (RegionT s pr) → RegionT s pr α) + → pr α +withCStringLen = withCAStringLen + +charIsRepresentable ∷ MonadIO m ⇒ Char → m Bool +charIsRepresentable = liftIO ∘ FCS.charIsRepresentable + + +-------------------------------------------------------------------------------- +-- Using 8-bit characters +-------------------------------------------------------------------------------- + +peekCAString ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCString pr → cr String +peekCAString = unsafeWrap FCS.peekCAString + +peekCAStringLen ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCStringLen pr → cr String +peekCAStringLen = liftIO ∘ FCS.peekCAStringLen ∘ first unsafePtr + +newCAString ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCString (RegionT s pr)) +newCAString = newArray0 nUL ∘ charsToCChars + +newCAStringLen ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCStringLen (RegionT s pr)) +newCAStringLen = newArrayLen ∘ charsToCChars + +withCAString ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCString (RegionT s pr) → RegionT s pr α) + → pr α +withCAString = withArray0 nUL ∘ charsToCChars + +withCAStringLen ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCStringLen (RegionT s pr) → RegionT s pr α) + → pr α +withCAStringLen str f = withArrayLen (charsToCChars str) + $ \len ptr → f (ptr, len) + + +-------------------------------------------------------------------------------- +-- C wide strings +-------------------------------------------------------------------------------- + +-- | Handy type synonym for a regional pointer to an array of C wide characters +-- terminated by a NUL. +-- +-- This should provide a safer replacement for @Foreign.C.String.'CWString'@. +type RegionalCWString r = RegionalPtr CWchar r + +-- | Handy type synonym for a regional pointer to an array of C wide characters +-- which is paired with the length of the array instead of terminated by a NUL. +-- (Thus allowing NUL characters in the middle of the string) +-- +-- This should provide a safer replacement for @Foreign.C.String.'CWStringLen'@. +type RegionalCWStringLen r = (RegionalPtr CWchar r, Int) + +peekCWString ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCWString pr → cr String +peekCWString = unsafeWrap FCS.peekCWString + +peekCWStringLen ∷ (pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalCWStringLen pr → cr String +peekCWStringLen = liftIO ∘ FCS.peekCWStringLen ∘ first unsafePtr + +newCWString ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCWString (RegionT s pr)) +newCWString = newArray0 wNUL ∘ charsToCWchars + +newCWStringLen ∷ MonadCatchIO pr + ⇒ String → RegionT s pr (RegionalCWStringLen (RegionT s pr)) +newCWStringLen = newArrayLen ∘ charsToCWchars + +withCWString ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCWString (RegionT s pr) → RegionT s pr α) + → pr α +withCWString = withArray0 wNUL ∘ charsToCWchars + +withCWStringLen ∷ MonadCatchIO pr + ⇒ String + → (∀ s. RegionalCWStringLen (RegionT s pr) → RegionT s pr α) + → pr α +withCWStringLen str f = withArrayLen (charsToCWchars str) + $ \len ptr → f (ptr, len) + + +-------------------------------------------------------------------------------- +-- Utility functions +-------------------------------------------------------------------------------- + +nUL ∷ CChar +nUL = 0 + +wNUL ∷ CWchar +wNUL = 0 + +-- | allocate an array to hold the list and pair it with the number of elements. +newArrayLen ∷ (Storable α, MonadCatchIO pr) + ⇒ [α] → RegionT s pr (RegionalPtr α (RegionT s pr), Int) +newArrayLen xs = do + a <- newArray xs + return (a, length xs) + +charsToCChars ∷ [Char] → [CChar] +charsToCChars = map FCS.castCharToCChar + +-- Note that the following is copied from 'Foreign.C.String': +charsToCWchars ∷ [Char] → [CWchar] + +#ifdef mingw32_HOST_OS +-- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding. +charsToCWchars = foldr utf16Char [] ∘ map ord + where + utf16Char c wcs + | c < 0x10000 = fromIntegral c : wcs + | otherwise = let c' = c - 0x10000 in + fromIntegral (c' `div` 0x400 + 0xd800) : + fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs + +#else +charsToCWchars = map castCharToCWchar + +-- These conversions only make sense if __STDC_ISO_10646__ is defined +-- (meaning that wchar_t is ISO 10646, aka Unicode) + +castCharToCWchar ∷ Char → CWchar +castCharToCWchar = fromIntegral ∘ ord +#endif + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Marshal/Alloc/Region.hs b/Foreign/Marshal/Alloc/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/Marshal/Alloc/Region.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE UnicodeSyntax + , NoImplicitPrelude + , RankNTypes + , ScopedTypeVariables + , CPP + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Marshal.Alloc.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +------------------------------------------------------------------------------- + +module Foreign.Marshal.Alloc.Region + ( -- * Local allocation + alloca + , allocaBytes + + -- * Dynamic allocation + , malloc + , mallocBytes + + -- | /TODO:/ Define and export: @realloc@ and @reallocBytes@. + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( undefined ) +import Data.Function ( ($) ) +import Data.Int ( Int ) +import Foreign.Storable ( Storable, sizeOf ) + +#ifdef __HADDOCK__ +import qualified Foreign.Marshal.Alloc as FMA ( alloca, allocaBytes + , malloc, mallocBytes + ) +#endif + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO ) + +-- from regions: +import Control.Monad.Trans.Region ( RegionT, open, with ) + +-- from ourselves: +import Foreign.Ptr.Region ( Memory(Memory), RegionalPtr ) + + +-------------------------------------------------------------------------------- +-- * Local allocation +-------------------------------------------------------------------------------- + +{-| Convenience function which allocates sufficient memory to hold values of +type @α@, applies the given continuation function to the resulting regional +pointer and runs the resulting region. + +This should provide a safer replacement for: +@Foreign.Marshal.Alloc.'FMA.alloca'@. + +Note that: @alloca = 'allocaBytes' $ 'sizeOf' (undefined :: α)@ +-} +alloca ∷ ∀ α pr β. (Storable α, MonadCatchIO pr) + ⇒ (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +alloca = allocaBytes $ sizeOf (undefined ∷ α) + +{-| Convenience function which allocates the given number of bytes, applies the +given continuation function to the resulting regional pointer and runs the +resulting region. + +This should provide a safer replacement for: +@Foreign.Marshal.Alloc.'FMA.allocaBytes'@. + +Note that: @allocaBytes = 'with' . 'Memory'@ +-} +allocaBytes ∷ ∀ α pr β. MonadCatchIO pr + ⇒ Int + → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +allocaBytes = with ∘ Memory + + +-------------------------------------------------------------------------------- +-- * Dynamic allocation +-------------------------------------------------------------------------------- + +{-| Convenience function which allocates sufficient memory to hold values of +type @α@ and returns a regional pointer to them. + +This should provide a safer replacement for: +@Foreign.Marshal.Alloc.'FMA.malloc'@. + +Note that: @malloc = 'mallocBytes' $ 'sizeOf' (undefined :: α)@ +-} +malloc ∷ ∀ α pr s. (Storable α, MonadCatchIO pr) + ⇒ RegionT s pr (RegionalPtr α (RegionT s pr)) +malloc = mallocBytes $ sizeOf (undefined ∷ α) + +{-| Convenience function which allocates the given number of bytes and returns a +regional pointer to them. + +This should provide a safer replacement for: +@Foreign.Marshal.Alloc.'FMA.mallocBytes'@. + +Note that: @mallocBytes = 'open' . 'Memory'@ +-} +mallocBytes ∷ MonadCatchIO pr + ⇒ Int + → RegionT s pr (RegionalPtr α (RegionT s pr)) +mallocBytes = open ∘ Memory + +-- TODO: +-- realloc ∷ (Storable β, pr `ParentOf` cr, MonadIO cr) +-- ⇒ RegionalPtr α pr → cr (RegionalPtr β pr) +-- realloc = ... +-- reallocBytes ∷ (pr `ParentOf` cr, MonadIO cr) +-- ⇒ RegionalPtr α pr → Int → cr (RegionalPtr α pr) +-- reallocBytes = ... + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Marshal/Array/Region.hs b/Foreign/Marshal/Array/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/Marshal/Array/Region.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE UnicodeSyntax + , NoImplicitPrelude + , RankNTypes + , ScopedTypeVariables + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Marshal.Array.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +------------------------------------------------------------------------------- + +module Foreign.Marshal.Array.Region + ( -- * Allocation + mallocArray + , mallocArray0 + , allocaArray + , allocaArray0 + + -- | /TODO:/ Define and export @reallocArray@ and @reallocArray0@ + + -- * Marshalling + , peekArray + , peekArray0 + , pokeArray + , pokeArray0 + + -- * Combined allocation and marshalling + , newArray + , newArray0 + , withArray + , withArray0 + , withArrayLen + , withArrayLen0 + + -- * Copying + , copyArray + , moveArray + + -- * Finding the length + , lengthArray0 + + -- * Indexing + , advancePtr + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( undefined, (*), succ ) +import Data.Function ( ($), flip, const ) +import Data.Int ( Int ) +import Data.List ( length ) +import Data.Eq ( Eq ) +import Control.Monad ( return, (>>=), fail + , (>>) + ) +import System.IO ( IO ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable, sizeOf ) +import qualified Foreign.Marshal.Array as FMA ( peekArray + , peekArray0 + , pokeArray + , pokeArray0 + , copyArray + , moveArray + , lengthArray0 + , advancePtr + ) +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from transformers: +import Control.Monad.Trans ( MonadIO, liftIO ) + +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO ) + +-- from regions: +import Control.Monad.Trans.Region ( RegionT , ParentOf ) + +-- from ourselves: +import Foreign.Ptr.Region ( RegionalPtr, mapRegionalPtr ) +import Foreign.Ptr.Region.Unsafe ( unsafePtr, unsafeWrap2 ) +import Foreign.Marshal.Alloc.Region ( mallocBytes, allocaBytes ) + + +-------------------------------------------------------------------------------- +-- Allocation +-------------------------------------------------------------------------------- + +mallocArray ∷ ∀ α s pr. (Storable α, MonadCatchIO pr) + ⇒ Int → RegionT s pr (RegionalPtr α (RegionT s pr)) +mallocArray size = mallocBytes $ size * sizeOf (undefined ∷ α) + +mallocArray0 ∷ (Storable α, MonadCatchIO pr) + ⇒ Int → RegionT s pr (RegionalPtr α (RegionT s pr)) +mallocArray0 = mallocArray ∘ succ + +allocaArray ∷ ∀ α pr β. (Storable α, MonadCatchIO pr) + ⇒ Int + → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +allocaArray size = allocaBytes $ size * sizeOf (undefined ∷ α) + +allocaArray0 ∷ ∀ α pr β. (Storable α, MonadCatchIO pr) + ⇒ Int + → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +allocaArray0 = allocaArray ∘ succ + +-- TODO: +-- reallocArray ∷ Storable α ⇒ RegionalPtr α pr → Int → cr (RegionalPtr α pr) +-- reallocArray0 ∷ Storable α ⇒ RegionalPtr α pr → Int → cr (RegionalPtr α pr) + + +-------------------------------------------------------------------------------- +-- Marshalling +-------------------------------------------------------------------------------- + +unsafeWrap2flp ∷ MonadIO m + ⇒ (γ → Ptr α → IO β) + → (γ → RegionalPtr α r → m β) +unsafeWrap2flp = flip ∘ unsafeWrap2 ∘ flip + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.peekArray'. +peekArray ∷ (Storable α, pr `ParentOf` cr, MonadIO cr) + ⇒ Int → RegionalPtr α pr → cr [α] +peekArray = unsafeWrap2flp FMA.peekArray + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.peekArray0'. +peekArray0 ∷ (Storable α, Eq α, pr `ParentOf` cr, MonadIO cr) + ⇒ α → RegionalPtr α pr → cr [α] +peekArray0 = unsafeWrap2flp FMA.peekArray0 + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.pokeArray'. +pokeArray ∷ (Storable α, pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalPtr α pr → [α] → cr () +pokeArray = unsafeWrap2 FMA.pokeArray + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.pokeArray0'. +pokeArray0 ∷ (Storable α, pr `ParentOf` cr, MonadIO cr) + ⇒ α → RegionalPtr α pr → [α] → cr () +pokeArray0 m rp xs = liftIO $ FMA.pokeArray0 m (unsafePtr rp) xs + + +-------------------------------------------------------------------------------- +-- Combined allocation and marshalling +-------------------------------------------------------------------------------- + +newArray ∷ (Storable α, MonadCatchIO pr) + ⇒ [α] → RegionT s pr (RegionalPtr α (RegionT s pr )) +newArray vals = do + ptr ← mallocArray $ length vals + pokeArray ptr vals + return ptr + +newArray0 ∷ (Storable α, MonadCatchIO pr) + ⇒ α → [α] → RegionT s pr (RegionalPtr α (RegionT s pr)) +newArray0 marker vals = do + ptr ← mallocArray0 $ length vals + pokeArray0 marker ptr vals + return ptr + +withArray ∷ (Storable α, MonadCatchIO pr) + ⇒ [α] + → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +withArray vals = withArrayLen vals ∘ const + +withArray0 ∷ (Storable α, MonadCatchIO pr) + ⇒ α + → [α] + → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +withArray0 marker vals = withArrayLen0 marker vals ∘ const + +withArrayLen ∷ (Storable α, MonadCatchIO pr) + ⇒ [α] + → (∀ s. Int → RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +withArrayLen vals f = + allocaArray len $ \ptr → do + pokeArray ptr vals + res ← f len ptr + return res + where + len = length vals + +withArrayLen0 ∷ (Storable α, MonadCatchIO pr) + ⇒ α + → [α] + → (∀ s. Int → RegionalPtr α (RegionT s pr) → RegionT s pr β) + → pr β +withArrayLen0 marker vals f = + allocaArray0 len $ \ptr → do + pokeArray0 marker ptr vals + res ← f len ptr + return res + where + len = length vals + + +-------------------------------------------------------------------------------- +-- Copying +-------------------------------------------------------------------------------- + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.copyArray'. +copyArray ∷ (Storable α, pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalPtr α pr → RegionalPtr α pr → Int → cr () +copyArray rp1 rp2 = liftIO ∘ FMA.copyArray (unsafePtr rp1) (unsafePtr rp2) + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.moveArray'. +moveArray ∷ (Storable α, pr `ParentOf` cr, MonadIO cr) + ⇒ RegionalPtr α pr → RegionalPtr α pr → Int → cr () +moveArray rp1 rp2 = liftIO ∘ FMA.moveArray (unsafePtr rp1) (unsafePtr rp2) + + +-------------------------------------------------------------------------------- +-- Finding the length +-------------------------------------------------------------------------------- + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.lengthArray0'. +lengthArray0 ∷ (Storable α, Eq α, pr `ParentOf` cr, MonadIO cr) + ⇒ α → RegionalPtr α pr → cr Int +lengthArray0 = unsafeWrap2flp FMA.lengthArray0 + + +-------------------------------------------------------------------------------- +-- Indexing +-------------------------------------------------------------------------------- + +-- | Wraps: @Foreign.Marshal.Array.@'FMA.advancePtr'. +advancePtr ∷ Storable α ⇒ RegionalPtr α pr → Int → RegionalPtr α pr +advancePtr rp i = mapRegionalPtr (\p → FMA.advancePtr p i) rp + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Marshal/Utils/Region.hs b/Foreign/Marshal/Utils/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/Marshal/Utils/Region.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE UnicodeSyntax + , NoImplicitPrelude + , RankNTypes + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Marshal.Utils.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +------------------------------------------------------------------------------- + +module Foreign.Marshal.Utils.Region + ( -- * General marshalling utilities + -- ** Combined allocation and marshalling + with + , new + + -- * Marshalling of Boolean values (non-zero corresponds to 'True') + , FMU.fromBool + , FMU.toBool + + -- ** Marshalling of Maybe values + -- | /TODO:/ Define and export: @maybeNew@, @maybeWith@ and @maybePeek@. + + -- ** Marshalling lists of storable objects + -- | /TODO:/ Define and export: @withMany@. + + -- ** Haskellish interface to memcpy and memmove + -- | (argument order: destination, source) + , copyBytes + , moveBytes + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Function ( ($) ) +import Data.Int ( Int ) +import Control.Monad ( return, (>>=), fail, (>>) ) +import Foreign.Storable ( Storable ) +import qualified Foreign.Marshal.Utils as FMU ( fromBool, toBool + , copyBytes, moveBytes + ) +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from transformers: +import Control.Monad.Trans ( MonadIO, liftIO ) + +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO ) + +-- from regions: +import Control.Monad.Trans.Region ( RegionT, ParentOf ) + +-- from ourselves: +import Foreign.Ptr.Region ( RegionalPtr ) +import Foreign.Ptr.Region.Unsafe ( unsafePtr ) +import Foreign.Marshal.Alloc.Region ( alloca, malloc ) +import Foreign.Storable.Region ( poke ) + + +-------------------------------------------------------------------------------- +-- * General marshalling utilities +-------------------------------------------------------------------------------- + +-- ** Combined allocation and marshalling + +with ∷ (Storable α, MonadCatchIO pr) + ⇒ α → (∀ s. RegionalPtr α (RegionT s pr) → RegionT s pr β) → pr β +with val f = alloca $ \ptr → poke ptr val >> f ptr + +new ∷ (Storable α, MonadCatchIO pr) + ⇒ α → RegionT s pr (RegionalPtr α (RegionT s pr)) +new val = do ptr ← malloc + poke ptr val + return ptr + +-- TODO: +-- -- ** Marshalling of Maybe values +-- maybeNew +-- maybeWith +-- maybePeek + +-- TODO +-- -- ** Marshalling lists of storable objects +-- withMany :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res + +-- ** Haskellish interface to memcpy and memmove + +copyBytes ∷ ( pr1 `ParentOf` cr + , pr2 `ParentOf` cr + , MonadIO cr + ) + ⇒ RegionalPtr α pr1 -- ^ Destination + → RegionalPtr α pr2 -- ^ Source + → Int → cr () +copyBytes rp1 rp2 = liftIO ∘ FMU.copyBytes (unsafePtr rp1) (unsafePtr rp2) + +moveBytes ∷ ( pr1 `ParentOf` cr + , pr2 `ParentOf` cr + , MonadIO cr + ) + ⇒ RegionalPtr α pr1 -- ^ Destination + → RegionalPtr α pr2 -- ^ Source + → Int → cr () +moveBytes rp1 rp2 = liftIO ∘ FMU.moveBytes (unsafePtr rp1) (unsafePtr rp2) + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Ptr/Region.hs b/Foreign/Ptr/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ptr/Region.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Ptr.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +------------------------------------------------------------------------------- + +module Foreign.Ptr.Region + ( -- * Memory as a scarce resource + Memory(..) + , RegionalPtr + + {-| Note that this module re-exports the @Control.Monad.Trans.Region@ + module from the @regions@ package which allows you to: + + * 'open' 'Memory' in a 'RegionT'. + + * Run a region using 'runRegionT'. + + * Concurrently run a region inside another region using 'forkTopRegion'. + + * Duplicate a regional pointer to a parent region using 'dup'. + -} + , module Control.Monad.Trans.Region + + -- * Pure functions on regional pointers + , mapRegionalPtr + + , castPtr + , plusPtr + , alignPtr + , minusPtr + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Int ( Int ) +import qualified Foreign.Ptr as FP ( castPtr, plusPtr, alignPtr, minusPtr ) + +-- from regions: +import Control.Monad.Trans.Region -- (re-exported entirely) + +-- from ourselves: +import Foreign.Ptr.Region.Internal ( Memory(..), RegionalPtr, mapRegionalPtr ) +import Foreign.Ptr.Region.Unsafe ( unsafePtr ) + + +-------------------------------------------------------------------------------- +-- Pure functions on regional pointers +-------------------------------------------------------------------------------- + +-- | Wraps: @Foreign.Ptr.@'FP.castPtr' +castPtr ∷ RegionalPtr α r → RegionalPtr β r +castPtr = mapRegionalPtr FP.castPtr + +-- | Wraps: @Foreign.Ptr.@'FP.plusPtr' +plusPtr ∷ RegionalPtr α r → Int → RegionalPtr β r +plusPtr rp n = mapRegionalPtr (\p → FP.plusPtr p n) rp + +-- | Wraps: @Foreign.Ptr.@'FP.alignPtr' +alignPtr ∷ RegionalPtr α r → Int → RegionalPtr α r +alignPtr rp n = mapRegionalPtr (\p → FP.alignPtr p n) rp + +-- | Wraps: @Foreign.Ptr.@'FP.minusPtr' +minusPtr ∷ RegionalPtr α r → RegionalPtr β r → Int +minusPtr rp1 rp2 = FP.minusPtr (unsafePtr rp1) (unsafePtr rp2) + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Ptr/Region/Internal.hs b/Foreign/Ptr/Region/Internal.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ptr/Region/Internal.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE UnicodeSyntax + , NoImplicitPrelude + , TypeFamilies + , CPP + #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Ptr.Region.Internal +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +------------------------------------------------------------------------------- + +module Foreign.Ptr.Region.Internal + ( -- * Memory as a scarce resource + Memory(..) + , RegionalPtr + + -- * Utility functions for lifting operations on Ptrs to RegionalPtrs + , mapRegionalPtr + , unsafePtr + , unsafeWrap, unsafeWrap2, unsafeWrap3 + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Function ( ($) ) +import Data.Int ( Int ) +import Control.Monad ( liftM ) +import System.IO ( IO ) +import Foreign.Ptr ( Ptr ) +import qualified Foreign.Marshal.Alloc as FMA ( mallocBytes, free ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from transformers: +import Control.Monad.Trans ( MonadIO, liftIO ) + +-- from regions: +import Control.Monad.Trans.Region ( RegionalHandle ) +import Control.Monad.Trans.Region.Unsafe ( Resource + , Handle + , openResource + , closeResource + , internalHandle + , mapInternalHandle + ) +#ifdef __HADDOCK__ +import Control.Monad.Trans.Region ( open ) +#endif + + +-------------------------------------------------------------------------------- +-- Memory as a scarce resource +-------------------------------------------------------------------------------- + +{-| Represents memory of 'size' number of bytes which may be marshalled to or +from Haskell values of type @α@. Before you can use the memory you have to +allocate it using 'open'. +-} +newtype Memory α = Memory { size ∷ Int } + +instance Resource (Memory α) where + newtype Handle (Memory α) = Pointer { ptr ∷ Ptr α } + + openResource = liftM Pointer ∘ FMA.mallocBytes ∘ size + closeResource = FMA.free ∘ ptr + +-- | Handy type synonym for a regional handle to memory. This should provide a +-- safer replacement for @Foreign.Ptr.@'Ptr' +type RegionalPtr α r = RegionalHandle (Memory α) r + + +-------------------------------------------------------------------------------- +-- Utility functions for lifting operations on Ptrs to RegionalPtrs +-------------------------------------------------------------------------------- + +mapRegionalPtr ∷ (Ptr α → Ptr β) → (RegionalPtr α r → RegionalPtr β r) +mapRegionalPtr f = mapInternalHandle $ Pointer ∘ f ∘ ptr + +unsafePtr ∷ RegionalPtr α r → Ptr α +unsafePtr = ptr ∘ internalHandle + +unsafeWrap ∷ MonadIO m + ⇒ (Ptr α → IO β) + → (RegionalPtr α r → m β) +unsafeWrap f rp = liftIO $ f $ unsafePtr rp + +unsafeWrap2 ∷ MonadIO m + ⇒ (Ptr α → γ → IO β) + → (RegionalPtr α r → γ → m β) +unsafeWrap2 f rp x = liftIO $ f (unsafePtr rp) x + +unsafeWrap3 ∷ MonadIO m + ⇒ (Ptr α → γ → δ → IO β) + → (RegionalPtr α r → γ → δ → m β) +unsafeWrap3 f rp x y = liftIO $ f (unsafePtr rp) x y + + +-- The End --------------------------------------------------------------------- diff --git a/Foreign/Ptr/Region/Unsafe.hs b/Foreign/Ptr/Region/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ptr/Region/Unsafe.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Ptr.Region.Unsfe +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- /Unsafe/ functions for retrieving the actual 'Ptr' from a regional pointer +-- and for lifting operations on 'Ptr's to 'RegionalPtr's. +-- +------------------------------------------------------------------------------- + +module Foreign.Ptr.Region.Unsafe + ( unsafePtr + , unsafeWrap, unsafeWrap2, unsafeWrap3 + ) where + +import Foreign.Ptr.Region.Internal ( unsafePtr + , unsafeWrap, unsafeWrap2, unsafeWrap3 + ) diff --git a/Foreign/Storable/Region.hs b/Foreign/Storable/Region.hs new file mode 100644 --- /dev/null +++ b/Foreign/Storable/Region.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Foreign.Storable.Region +-- Copyright : (c) 2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- Lifts methods of the 'Storable' type class from @Foreign.Storable@ to +-- regional pointers. +-- +------------------------------------------------------------------------------- + +module Foreign.Storable.Region + ( peekElemOff, pokeElemOff + , peekByteOff, pokeByteOff + , peek, poke + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Int ( Int ) +import Foreign.Storable ( Storable ) +import qualified Foreign.Storable as FS ( peekElemOff, pokeElemOff + , peekByteOff, pokeByteOff + , peek, poke + ) +-- from transformers: +import Control.Monad.Trans ( MonadIO ) + +-- from regions: +import Control.Monad.Trans.Region ( ParentOf ) + +-- from ourselves: +import Foreign.Ptr.Region ( RegionalPtr ) +import Foreign.Ptr.Region.Unsafe ( unsafeWrap, unsafeWrap2, unsafeWrap3 ) + + +-------------------------------------------------------------------------------- +-- Storable methods lifted to a region +-------------------------------------------------------------------------------- + +-- | Wraps: @Foreign.Storable.'FS.peekElemOff'@. +peekElemOff ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr α pr → Int → cr α +peekElemOff = unsafeWrap2 FS.peekElemOff + +-- | Wraps: @Foreign.Storable.'FS.pokeElemOff'@. +pokeElemOff ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr α pr → Int → α → cr () +pokeElemOff = unsafeWrap3 FS.pokeElemOff + +-- | Wraps: @Foreign.Storable.'FS.peekByteOff'@. +peekByteOff ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr β pr → Int → cr α +peekByteOff = unsafeWrap2 FS.peekByteOff + +-- | Wraps: @Foreign.Storable.'FS.pokeByteOff'@. +pokeByteOff ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr β pr → Int → α → cr () +pokeByteOff = unsafeWrap3 FS.pokeByteOff + +-- | Wraps: @Foreign.Storable.'FS.peek'@. +peek ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr α pr → cr α +peek = unsafeWrap FS.peek + +-- | Wraps: @Foreign.Storable.'FS.poke'@. +poke ∷ (pr `ParentOf` cr, Storable α, MonadIO cr) + ⇒ RegionalPtr α pr → α → cr () +poke = unsafeWrap2 FS.poke + + +-- The End --------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009 Bas van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The name of Bas van Dijk and the names of contributors may NOT + be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,21 @@ +#! /usr/bin/env runhaskell + +{-# OPTIONS -Wall #-} + +import Distribution.Simple ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(haddockHook) + ) +import Distribution.Simple.Setup ( HaddockFlags ) +import Distribution.Simple.Program ( userSpecifyArgs ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(withPrograms) ) +import Distribution.PackageDescription ( PackageDescription ) + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { haddockHook = haddockHook' } + +-- Define __HADDOCK__ for CPP when running haddock. +haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () +haddockHook' pkg lbi = haddockHook simpleUserHooks pkg $ lbi { withPrograms = p } + where + p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) diff --git a/regional-pointers.cabal b/regional-pointers.cabal new file mode 100644 --- /dev/null +++ b/regional-pointers.cabal @@ -0,0 +1,59 @@ +name: regional-pointers +version: 0.1 +cabal-version: >=1.6 +build-type: Custom +license: BSD3 +license-file: LICENSE +copyright: 2010 Bas van Dijk +author: Bas van Dijk +maintainer: Bas van Dijk +stability: experimental +category: System, Monadic Regions +synopsis: Regional memory pointers +description: The library allows you to allocate memory in a region yielding a + regional pointer to it. When the region terminates all pointers + are automatically freed. Most importantly, a pointer can't be + returned from the region. So it's impossible to reference + unallocated memory. + + . + + The primary technique used in this package is called \"Lightweight + monadic regions\" which was invented by Oleg Kiselyov and + Chung-chieh Shan. See: + + . + + + + . + + This technique is implemented in the @regions@ package which is + re-exported from this library. + + . + + This library provides wrappers around all the @Ptr@ functions + from the @Foreign.*@ modules from @base@. + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/regional-pointers + +Library + GHC-Options: -Wall + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.2 + , regions == 0.3.* + , transformers >= 0.1.4 && < 0.2 + , MonadCatchIO-transformers == 0.0.2.* + exposed-modules: Foreign.Ptr.Region + Foreign.Ptr.Region.Unsafe + Foreign.Marshal.Alloc.Region + Foreign.Marshal.Array.Region + Foreign.Marshal.Utils.Region + Foreign.Storable.Region + Foreign.C.String.Region + -- TODO: Foreign.StablePtr.Region + -- TODO: Foreign.Marshal.Pool.Region + other-modules: Foreign.Ptr.Region.Internal