primitive-maybe (empty) → 0.1.0

raw patch · 8 files changed

+281/−0 lines, 8 filesdep +basedep +primitivedep +primitive-maybesetup-changed

Dependencies added: base, primitive, primitive-maybe

Files

• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• primitive-maybe.cabal +46/−0
• src/Data/Primitive/Array/Maybe.hs +95/−0
• src/Data/Primitive/Maybe/Internal.hs +10/−0
• src/Data/Primitive/SmallArray/Maybe.hs +95/−0
• test/Main.hs +2/−0

@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2018++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.++    * Neither the name of Andrew Martin nor the names of other+      contributors may 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.

@@ -0,0 +1,1 @@+# primitive-maybe

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,46 @@+cabal-version: 2.0+name: primitive-maybe+version: 0.1.0+synopsis: Arrays of Maybes+description:+  This library provides types for working with arrays of @Maybe@+  values. The types in this library can be used as replacements+  for @Array (Maybe a)@ and @SmallArray (Maybe a)@ that consume+  less memory and have fewer indirections.+homepage: https://github.com/andrewthad/primitive-maybe#readme+bug-reports: https://github.com/andrewthad/primitive-maybe/issues+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2018 Andrew Martin+license: BSD3+license-file: LICENSE+build-type: Simple+category: Array+extra-source-files: README.md++source-repository head+  type: git+  location: https://github.com/andrewthad/primitive-maybe++library+  exposed-modules:+    Data.Primitive.Array.Maybe+    Data.Primitive.SmallArray.Maybe+  other-modules:+    Data.Primitive.Maybe.Internal+  hs-source-dirs: src+  build-depends:+      base >=4.9.1.0 && <5+    , primitive >= 0.6.4+  ghc-options: -O2 -Wall+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.9.1.0 && <5+    , primitive-maybe+  default-language: Haskell2010

@@ -0,0 +1,95 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RoleAnnotations #-}++-- | This provides an interface to working with boxed arrays+-- with elements of type @Maybe a@. That is:+--+-- > MaybeArray a ≅ Array (Maybe a)+--+-- However, this type provided by this module is more efficient+-- than its naive @Array@ counterpart. It consumes less+-- memory and has fewer heap indirections.+module Data.Primitive.Array.Maybe+  ( MaybeArray+  , MutableMaybeArray+  , indexMaybeArray+  , newMaybeArray+  , readMaybeArray+  , writeMaybeArray+  , sequenceMaybeArray+  , unsafeFreezeMaybeArray+  ) where++import Control.Monad.Primitive+import Data.Primitive.Array++import Data.Primitive.Maybe.Internal (nothingSurrogate)+import GHC.Exts (Any,reallyUnsafePtrEquality#)+import Unsafe.Coerce (unsafeCoerce)++newtype MaybeArray a = MaybeArray (Array Any)+newtype MutableMaybeArray s a = MutableMaybeArray (MutableArray s Any)++type role MaybeArray representational+type role MutableMaybeArray nominal representational++unsafeToMaybe :: Any -> Maybe a+unsafeToMaybe a =+  case reallyUnsafePtrEquality# a nothingSurrogate of+    0# -> Just (unsafeCoerce a)+    _  -> Nothing+{-# INLINE unsafeToMaybe #-}++newMaybeArray :: PrimMonad m => Int -> Maybe a -> m (MutableMaybeArray (PrimState m) a)+{-# INLINE newMaybeArray #-}+newMaybeArray i ma = case ma of+  Just a -> do+    x <- newArray i (unsafeCoerce a)+    return (MutableMaybeArray x)+  Nothing -> do+    x <- newArray i nothingSurrogate+    return (MutableMaybeArray x)++indexMaybeArray :: MaybeArray a -> Int -> Maybe a+{-# INLINE indexMaybeArray #-}+indexMaybeArray (MaybeArray a) ix =+  let (# v #) = indexArray## a ix+   in unsafeToMaybe v++readMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> Int -> m (Maybe a)+{-# INLINE readMaybeArray #-}+readMaybeArray (MutableMaybeArray m) ix = do+  a <- readArray m ix+  return (unsafeToMaybe a)++writeMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> Int -> Maybe a -> m ()+{-# INLINE writeMaybeArray #-}+writeMaybeArray (MutableMaybeArray marr) ix ma = case ma of+  Just a -> writeArray marr ix (unsafeCoerce a)+  Nothing -> writeArray marr ix nothingSurrogate++-- | This is like calling @sequence@ on an 'Array'. However, in+-- the event that all the values are @Just@, it does not need+-- to allocate a new array since the array backing the @MaybeArray@+-- can be reused.+sequenceMaybeArray :: MaybeArray a -> Maybe (Array a)+sequenceMaybeArray m@(MaybeArray a) =+  if hasNothing m then Nothing else Just (unsafeCoerce a)++hasNothing :: MaybeArray a -> Bool+hasNothing (MaybeArray a) = go 0 where+  go !ix = if ix < sizeofArray a+    then+      let (# v #) = indexArray## a ix+       in case reallyUnsafePtrEquality# v nothingSurrogate of+            0# -> True+            _  -> go (ix + 1)+    else False++unsafeFreezeMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> m (MaybeArray a)+{-# INLINE unsafeFreezeMaybeArray #-}+unsafeFreezeMaybeArray (MutableMaybeArray ma) = do+  a <- unsafeFreezeArray ma+  return (MaybeArray a)

@@ -0,0 +1,10 @@+module Data.Primitive.Maybe.Internal+  ( nothingSurrogate+  ) where++import GHC.Exts (Any)++nothingSurrogate :: Any+nothingSurrogate = error "nothingSurrogate: This value should not be forced!"+{-# NOINLINE nothingSurrogate #-}+

@@ -0,0 +1,95 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RoleAnnotations #-}++-- | This provides an interface to working with boxed arrays+-- with elements of type @Maybe a@. That is:+--+-- > SmallMaybeArray a ≅ SmallArray (Maybe a)+--+-- However, this type provided by this module is more efficient+-- than its naive @SmallArray@ counterpart. It consumes less+-- memory and has fewer heap indirections.+module Data.Primitive.SmallArray.Maybe+  ( SmallMaybeArray+  , SmallMutableMaybeArray+  , indexSmallMaybeArray+  , newSmallMaybeArray+  , readSmallMaybeArray+  , writeSmallMaybeArray+  , sequenceSmallMaybeArray+  , unsafeFreezeSmallMaybeArray+  ) where++import Control.Monad.Primitive+import Data.Primitive.SmallArray++import Data.Primitive.Maybe.Internal (nothingSurrogate)+import GHC.Exts (Any,reallyUnsafePtrEquality#)+import Unsafe.Coerce (unsafeCoerce)++newtype SmallMaybeArray a = SmallMaybeArray (SmallArray Any)+newtype SmallMutableMaybeArray s a = SmallMutableMaybeArray (SmallMutableArray s Any)++type role SmallMaybeArray representational+type role SmallMutableMaybeArray nominal representational++unsafeToMaybe :: Any -> Maybe a+unsafeToMaybe a =+  case reallyUnsafePtrEquality# a nothingSurrogate of+    0# -> Just (unsafeCoerce a)+    _  -> Nothing+{-# INLINE unsafeToMaybe #-}++newSmallMaybeArray :: PrimMonad m => Int -> Maybe a -> m (SmallMutableMaybeArray (PrimState m) a)+{-# INLINE newSmallMaybeArray #-}+newSmallMaybeArray i ma = case ma of+  Just a -> do+    x <- newSmallArray i (unsafeCoerce a)+    return (SmallMutableMaybeArray x)+  Nothing -> do+    x <- newSmallArray i nothingSurrogate+    return (SmallMutableMaybeArray x)++indexSmallMaybeArray :: SmallMaybeArray a -> Int -> Maybe a+{-# INLINE indexSmallMaybeArray #-}+indexSmallMaybeArray (SmallMaybeArray a) ix =+  let (# v #) = indexSmallArray## a ix+   in unsafeToMaybe v++readSmallMaybeArray :: PrimMonad m => SmallMutableMaybeArray (PrimState m) a -> Int -> m (Maybe a)+{-# INLINE readSmallMaybeArray #-}+readSmallMaybeArray (SmallMutableMaybeArray m) ix = do+  a <- readSmallArray m ix+  return (unsafeToMaybe a)++writeSmallMaybeArray :: PrimMonad m => SmallMutableMaybeArray (PrimState m) a -> Int -> Maybe a -> m ()+{-# INLINE writeSmallMaybeArray #-}+writeSmallMaybeArray (SmallMutableMaybeArray marr) ix ma = case ma of+  Just a -> writeSmallArray marr ix (unsafeCoerce a)+  Nothing -> writeSmallArray marr ix nothingSurrogate++-- | This is like calling @sequence@ on a 'SmallArray'. However, in+-- the event that all the values are @Just@, it does not need+-- to allocate a new array since the array backing the @SmallMaybeArray@+-- can be reused.+sequenceSmallMaybeArray :: SmallMaybeArray a -> Maybe (SmallArray a)+sequenceSmallMaybeArray m@(SmallMaybeArray a) =+  if hasNothing m then Nothing else Just (unsafeCoerce a)++hasNothing :: SmallMaybeArray a -> Bool+hasNothing (SmallMaybeArray a) = go 0 where+  go !ix = if ix < sizeofSmallArray a+    then+      let (# v #) = indexSmallArray## a ix+       in case reallyUnsafePtrEquality# v nothingSurrogate of+            0# -> True+            _  -> go (ix + 1)+    else False++unsafeFreezeSmallMaybeArray :: PrimMonad m => SmallMutableMaybeArray (PrimState m) a -> m (SmallMaybeArray a)+{-# INLINE unsafeFreezeSmallMaybeArray #-}+unsafeFreezeSmallMaybeArray (SmallMutableMaybeArray ma) = do+  a <- unsafeFreezeSmallArray ma+  return (SmallMaybeArray a)

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"