primitive-maybe 0.1.0 → 0.1.1

raw patch · 5 files changed

+983/−23 lines, 5 filesdep +QuickCheckdep +quickcheck-classesdep +taggeddep ~primitivenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, quickcheck-classes, tagged, tasty, tasty-quickcheck

Dependency ranges changed: primitive

API changes (from Hackage documentation)

Files

• primitive-maybe.cabal +7/−1
• src/Data/Primitive/Array/Maybe.hs +383/−10
• src/Data/Primitive/Maybe/Internal.hs +98/−1
• src/Data/Primitive/SmallArray/Maybe.hs +386/−10
• test/Main.hs +109/−1

@@ -1,6 +1,6 @@ cabal-version: 2.0 name: primitive-maybe-version: 0.1.0+version: 0.1.1 synopsis: Arrays of Maybes description:   This library provides types for working with arrays of @Maybe@@@ -43,4 +43,10 @@   build-depends:       base >=4.9.1.0 && <5     , primitive-maybe+    , primitive+    , QuickCheck+    , tasty+    , tasty-quickcheck+    , tagged+    , quickcheck-classes >= 0.4.11.1   default-language: Haskell2010

@@ -1,7 +1,13 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  -- | This provides an interface to working with boxed arrays -- with elements of type @Maybe a@. That is:@@ -20,28 +26,348 @@   , writeMaybeArray   , sequenceMaybeArray   , unsafeFreezeMaybeArray+  , thawMaybeArray+  , maybeArrayFromList+  , maybeArrayFromListN+  , sizeofMaybeArray   ) where +import Prelude hiding (zipWith)+import Control.Applicative (Alternative(..), liftA2)+import Control.Monad (when, MonadPlus(..))+import Control.Monad.Fail (MonadFail(..))+import Control.Monad.ST (ST, runST)+import Control.Monad.Zip (MonadZip(..)) import Control.Monad.Primitive import Data.Primitive.Array+import Data.Primitive.UnliftedArray (PrimUnlifted)+import Data.Foldable hiding (toList)+import Data.Functor.Classes+import qualified Data.Foldable as Foldable+import Data.Maybe (maybe) -import Data.Primitive.Maybe.Internal (nothingSurrogate)-import GHC.Exts (Any,reallyUnsafePtrEquality#)+import Data.Data+  (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)+import Data.Primitive.Maybe.Internal+import GHC.Exts (Any,reallyUnsafePtrEquality#, Int(..), IsList(..), MutableArray#)+import Text.ParserCombinators.ReadP import Unsafe.Coerce (unsafeCoerce) +-- | An immutable array of boxed values of type @'Maybe' a@. newtype MaybeArray a = MaybeArray (Array Any)+  deriving (PrimUnlifted)+-- | A mutable array of boxed values of type @'Maybe' a@. newtype MutableMaybeArray s a = MutableMaybeArray (MutableArray s Any)+  deriving (PrimUnlifted)  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 #-}+instance Functor MaybeArray where+  fmap :: forall a b. (a -> b) -> MaybeArray a -> MaybeArray b+  fmap f (MaybeArray arr) = MaybeArray $+    createArray (sizeofArray arr) (error "impossible") $ \mb ->+      let go i+            | i == (sizeofArray arr) = return ()+            | otherwise = do+                x <- indexArrayM arr i+                case unsafeToMaybe x of+                  Nothing -> pure () +                  Just val -> writeArray mb i (toAny (f val))+                go (i + 1)+      in go 0+  e <$ (MaybeArray a) = MaybeArray $ createArray (sizeofArray a) (toAny e) (\ !_ -> pure ()) +instance Applicative MaybeArray where+  pure :: a -> MaybeArray a+  pure a = MaybeArray $ runArray $ newArray 1 (toAny a)+  (<*>) :: MaybeArray (a -> b) -> MaybeArray a -> MaybeArray b+  abm@(MaybeArray ab) <*> am@(MaybeArray a) = MaybeArray $ createArray (szab * sza) nothingSurrogate $ \mb ->+    let go1 i = when (i < szab) $ do+          case indexMaybeArray abm i of+            Nothing -> pure ()+            Just f -> go2 (i * sza) f 0+          go1 (i + 1)+        go2 off f j = when (j < sza) $ do+          case indexMaybeArray am j of+            Nothing -> pure ()+            Just v -> writeArray mb (off + j) (toAny (f v))+          go2 off f (j + 1)+    in go1 0+      where szab = sizeofArray ab; sza = sizeofArray a+  MaybeArray a *> MaybeArray b = MaybeArray $ createArray (sza * szb) nothingSurrogate $ \mb ->+    let go i | i < sza = copyArray mb (i * szb) b 0 szb+             | otherwise = return ()+    in go 0+      where sza = sizeofArray a; szb = sizeofArray b+  MaybeArray a <* MaybeArray b = MaybeArray $ createArray (sza*szb) nothingSurrogate $ \ma ->+    let fill off i e | i < szb   = writeArray ma (off+i) e >> fill off (i+1) e+                     | otherwise = return ()+        go i | i < sza+             = do x <- indexArrayM a i+                  fill (i*szb) 0 x >> go (i+1)+             | otherwise = return ()+     in go 0+   where sza = sizeofArray a ; szb = sizeofArray b++instance Traversable MaybeArray where+  traverse = traverseArray++traverseArray :: Applicative f+  => (a -> f b)+  -> MaybeArray a+  -> f (MaybeArray b)+traverseArray f =  \ !(MaybeArray ary) ->+  let+    !len = sizeofArray ary+    go !ix+      | ix == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary)+      | otherwise = let x = indexArray ary ix+                    in case unsafeToMaybe x of+                      Nothing -> go (ix + 1)+                      Just v -> liftA2 (\b (STA m) -> STA $ \mary ->+                                          writeArray (MutableArray mary) ix (toAny b) >> m mary)+                                       (f v) (go (ix + 1))+  in if len == 0+       then pure mempty+       else MaybeArray <$> runSTA len <$> go 0++newtype STA a = STA { _runSTA :: forall s. MutableArray# s a -> ST s (Array a) }++runSTA :: Int -> STA a -> Array a+runSTA !sz = \(STA m) -> runST $ newArray_ sz >>= \ar -> m (marray# ar)++newArray_ :: Int -> ST s (MutableArray s a)+newArray_ !n = newArray n badTraverseValue++badTraverseValue :: a+badTraverseValue = error "traverse: bad indexing"++instance Alternative MaybeArray where+  empty = mempty+  (<|>) = (<>)+  some a | sizeofMaybeArray a == 0 = mempty+         | otherwise = error "some: infinite arrays are not well defined"+  many a | sizeofMaybeArray a == 0 = pure []+         | otherwise = error "many: infinite arrays are not well defined"++instance MonadPlus MaybeArray where+  mzero = empty+  mplus = (<|>)++instance MonadFail MaybeArray where+  fail _ = empty++zipWith :: (a -> b -> c) -> MaybeArray a -> MaybeArray b -> MaybeArray c+zipWith f (MaybeArray aa) (MaybeArray ab) = MaybeArray $+  createArray mn nothingSurrogate $ \mc ->+    let go i+          | i < mn = do+              x <- indexArrayM aa i+              y <- indexArrayM ab i+              let x' = unsafeToMaybe x+                  y' = unsafeToMaybe y+              case x' of+                Nothing -> go (i + 1)+                Just va -> case y' of+                  Nothing -> go (i + 1)+                  Just vb -> writeArray mc i (toAny $ f va vb) >> go (i + 1)+          | otherwise = return ()+    in go 0+  where mn = sizeofArray aa `min` sizeofArray ab++instance MonadZip MaybeArray where+  mzip aa ab = zipWith (,) aa ab+  mzipWith f aa ab = zipWith f aa ab+  munzip :: forall a b. MaybeArray (a, b) -> (MaybeArray a, MaybeArray b) +  munzip (MaybeArray aab) = runST $ do+    let sz = sizeofArray aab+    ma_ <- newArray sz nothingSurrogate :: ST s (MutableArray s Any)+    mb_ <- newArray sz nothingSurrogate :: ST s (MutableArray s Any)+    let go :: forall s. Int -> MutableArray s Any -> MutableArray s Any -> ST s ()+        go i ma mb = if i < sz+          then do+            tab <- indexArrayM aab i+            let (a, b) = fromAny tab+                a' = unsafeToMaybe a+                b' = unsafeToMaybe b+            maybe (pure ()) (writeArray ma i) a'+            maybe (pure ()) (writeArray mb i) b'+            go (i + 1) ma mb+          else return ()+    +    go 0 ma_ mb_+    (ma1, ma2) <- (,) <$> unsafeFreezeArray ma_ <*> unsafeFreezeArray mb_+    return (unsafeCoerce ma1, unsafeCoerce ma2) :: ST s (MaybeArray a, MaybeArray b)++data ArrayStack a+  = PushArray !(Array a) !(ArrayStack a)+  | EmptyStack++instance Monad MaybeArray where+  return = pure+  (>>) = (*>)+  (MaybeArray ary) >>= f = MaybeArray $ collect 0 EmptyStack (la - 1)+    where+      la = sizeofArray ary+      collect sz stk i+        | i < 0 = createArray sz nothingSurrogate $ fill 0 stk+        | otherwise = let x = indexArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> collect sz stk (i - 1)+                        Just v -> let (MaybeArray sb) = f v+                                      lsb = sizeofArray sb+                                  in if lsb == 0+                                       then collect sz stk (i - 1)+                                       else collect (sz + lsb) (PushArray sb stk) (i - 1)+      fill _ EmptyStack _ = return ()+      fill off (PushArray sb sbs) smb+        | let lsb = sizeofArray sb+        = copyArray smb off sb 0 lsb+            *> fill (off + lsb) sbs smb++instance Foldable MaybeArray where+  -- Note: we perform the array lookups eagerly so we won't+  -- create thunks to perform lookups even if GHC can't see+  -- that the folding function is strict.+  foldr f = \z !(MaybeArray ary) ->+    let+      !sz = sizeofArray ary+      go i+        | i == sz = z+        | otherwise = let !x = indexArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> z+                        Just val -> f val (go (i + 1))+    in go 0+  {-# INLINE foldr #-}+  foldl f = \z !(MaybeArray ary) ->+    let+      go i+        | i < 0 = z+        | otherwise = let !x = indexArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> z+                        Just val -> f (go (i - 1)) val+    in go (sizeofArray ary - 1)+  {-# INLINE foldl #-}+  null (MaybeArray a) = sizeofArray a == 0+  {-# INLINE null #-}+  length (MaybeArray a) = sizeofArray a+  {-# INLINE length #-}+  sum = foldl' (+) 0+  {-# INLINE sum #-}+  product = foldl' (*) 1+  {-# INLINE product #-}++instance Semigroup (MaybeArray a) where+  (<>) :: MaybeArray a -> MaybeArray a -> MaybeArray a+  MaybeArray a1 <> MaybeArray a2 = MaybeArray $+    createArray (sza1 + sza2) nothingSurrogate $ \ma ->+      copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2+    where+      sza1 = sizeofArray a1; sza2 = sizeofArray a2++instance Monoid (MaybeArray a) where+  mempty = MaybeArray emptyArray+  mappend = (<>)++instance IsList (MaybeArray a) where+  type Item (MaybeArray a) = a+  fromListN = maybeArrayFromListN+  fromList  = maybeArrayFromList+  toList    = Foldable.toList++instance Eq a => Eq (MaybeArray a) where+  sma1 == sma2 = maybeArrayLiftEq (==) sma1 sma2++instance Eq1 MaybeArray where+  liftEq = maybeArrayLiftEq++instance Ord1 MaybeArray where+  liftCompare = maybeArrayLiftCompare++maybeArrayLiftEq :: (a -> b -> Bool) -> MaybeArray a -> MaybeArray b -> Bool+maybeArrayLiftEq p (MaybeArray sa1) (MaybeArray sa2) = length sa1 == length sa2 && loop (length sa1 - 1)+  where+    loop i+      | i < 0 = True+      | otherwise = let x = unsafeToMaybe (indexArray sa1 i)+                        y = unsafeToMaybe (indexArray sa2 i)+                    in case x of+                      Nothing -> case y of+                        Nothing -> True && loop (i - 1)+                        _       -> False+                      Just x' -> case y of+                        Nothing -> False+                        Just y' -> p x' y' && loop (i - 1)++maybeArrayLiftCompare :: (a -> b -> Ordering) -> MaybeArray a -> MaybeArray b -> Ordering+maybeArrayLiftCompare elemCompare (MaybeArray a1) (MaybeArray a2) = loop 0+  where+    la1 = length a1+    la2 = length a2+    mn = la1 `min` la2+    loop i+      | i < mn = let x = unsafeToMaybe (indexArray a1 i)+                     y = unsafeToMaybe (indexArray a2 i)+                 in case x of+                   Nothing -> case y of+                     Nothing -> EQ `mappend` loop (i + 1)+                     _       -> LT+                   Just x' -> case y of+                     Nothing -> GT+                     Just y' -> elemCompare x' y' `mappend` loop (i     + 1)+     | otherwise = compare la1 la2++instance Ord a => Ord (MaybeArray a) where+  compare sma1 sma2 = maybeArrayLiftCompare compare sma1 sma2++maybeArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> MaybeArray a -> ShowS+maybeArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $+  showString "fromListN " . shows (length sa) . showString " "+  . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)++listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS+listLiftShowsPrec _ sl _ = sl++instance Show1 MaybeArray where+  liftShowsPrec = maybeArrayLiftShowsPrec++instance Show a => Show (MaybeArray a) where+  showsPrec p sa = maybeArrayLiftShowsPrec showsPrec showList p sa++maybeArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (MaybeArray a)+maybeArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do+  () <$ string "fromListN"+  skipSpaces+  n <- readS_to_P reads+  skipSpaces+  l <- readS_to_P listReadsPrec+  return $ maybeArrayFromListN n l++instance Read1 MaybeArray where+  liftReadsPrec = maybeArrayLiftReadsPrec++instance Read a => Read (MaybeArray a) where+  readsPrec = maybeArrayLiftReadsPrec readsPrec readList++maybeArrayDataType :: DataType+maybeArrayDataType = mkDataType "Data.Primitive.Array.Maybe.MaybeArray" [fromListConstr]++fromListConstr :: Constr+fromListConstr = mkConstr maybeArrayDataType "fromList" [] Prefix++instance Data a => Data (MaybeArray a) where+  toConstr _ = fromListConstr+  dataTypeOf _ = maybeArrayDataType+  gunfold k z c = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  gfoldl f z m = z fromList `f` toList m++-- | Create a new 'MutableMaybeArray' of the given size and initialize all elements+--   with the given 'Maybe' value. newMaybeArray :: PrimMonad m => Int -> Maybe a -> m (MutableMaybeArray (PrimState m) a) {-# INLINE newMaybeArray #-} newMaybeArray i ma = case ma of@@ -52,18 +378,21 @@     x <- newArray i nothingSurrogate     return (MutableMaybeArray x) +-- | Get the 'Maybe' value at the given index out of a 'MaybeArray'. indexMaybeArray :: MaybeArray a -> Int -> Maybe a {-# INLINE indexMaybeArray #-} indexMaybeArray (MaybeArray a) ix =   let (# v #) = indexArray## a ix    in unsafeToMaybe v +-- | Get the 'Maybe' value at the given index out of a 'MutableMaybeArray'. 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) +-- | Write a 'Maybe' value to the given index of a 'MutableMaybeArray'. writeMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> Int -> Maybe a -> m () {-# INLINE writeMaybeArray #-} writeMaybeArray (MutableMaybeArray marr) ix ma = case ma of@@ -78,18 +407,62 @@ sequenceMaybeArray m@(MaybeArray a) =   if hasNothing m then Nothing else Just (unsafeCoerce a) +-- | Returns @True@ if the 'MaybeArray' contains a @Nothing@ value. 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)+            0# -> go (ix + 1)+            _ -> True     else False +-- | Convert a 'MutableMaybeArray' to an immutable one without copying.+--   The array should not be modified after the conversion. unsafeFreezeMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> m (MaybeArray a) {-# INLINE unsafeFreezeMaybeArray #-} unsafeFreezeMaybeArray (MutableMaybeArray ma) = do   a <- unsafeFreezeArray ma   return (MaybeArray a)++-- | Create a 'MutablePrimArray' from a slice of an immutable array.+--   This operation makes a copy of the specified slice, so it is safe+--   to use the immutable array afterward.+thawMaybeArray+  :: PrimMonad m+  => MaybeArray a -- ^ source+  -> Int -- ^ offset+  -> Int -- ^ length+  -> m (MutableMaybeArray (PrimState m) a)+thawMaybeArray (MaybeArray a) off len =+  fmap MutableMaybeArray (thawArray a off len)++-- | Given the length of a list and a list of @a@,+--   build a 'MaybeArray' from the values in the list.+--   If the given 'Int' does not match the length of+--   the list, this function calls 'error'.+--   You should prefer this to 'maybeArrayFromList' if+--   the length of the list has already been computed.+maybeArrayFromListN :: Int -> [a] -> MaybeArray a+maybeArrayFromListN n l = MaybeArray $+  createArray n (error "uninitialized element") $ \sma ->+    let go !ix [] = if ix == n+          then return ()+          else error "list length less than specified size"+        go !ix (x : xs) = if ix < n+          then do+            writeArray sma ix (toAny x)+            go (ix+1) xs+          else error "list length greater than specified size"+    in go 0 l++-- | Given a list of @a@, build a 'MaybeArray' from+--   the values in the list.+maybeArrayFromList :: [a] -> MaybeArray a+maybeArrayFromList l = maybeArrayFromListN (length l) l++-- | Yield the size of the 'MaybeArray'.+sizeofMaybeArray :: MaybeArray a -> Int+sizeofMaybeArray (MaybeArray a) = sizeofArray a+{-# INLINE sizeofMaybeArray #-}

@@ -1,10 +1,107 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UnboxedTuples #-}+ module Data.Primitive.Maybe.Internal   ( nothingSurrogate+  , unsafeToMaybe +  , toAny+  , fromAny+  , toAny1+  , fromAny1+  , anyToFunctor+  , functorToAny++  , createArray+  , createSmallArray+  , emptyArray+  , emptySmallArray   ) where -import GHC.Exts (Any)+import Data.Primitive.Array+import Data.Primitive.SmallArray+import Control.Monad.ST (ST, runST)+import GHC.Exts (Any, reallyUnsafePtrEquality#, Array#, SmallArray#)+import Unsafe.Coerce (unsafeCoerce)  nothingSurrogate :: Any nothingSurrogate = error "nothingSurrogate: This value should not be forced!" {-# NOINLINE nothingSurrogate #-}+-- inlining this = fearful concurrency +unsafeToMaybe :: Any -> Maybe a+unsafeToMaybe a =+  case reallyUnsafePtrEquality# a nothingSurrogate of+    1#  -> Nothing+    _ -> Just (fromAny a)+{-# INLINE unsafeToMaybe #-}++toAny :: a -> Any+toAny = unsafeCoerce+{-# INLINE toAny #-}++toAny1 :: f a -> f Any+toAny1 = unsafeCoerce+{-# INLINE toAny1 #-}++fromAny1 :: f Any -> f a+fromAny1 = unsafeCoerce+{-# INLINE fromAny1 #-}++fromAny :: Any -> a+fromAny = unsafeCoerce+{-# INLINE fromAny #-}++anyToFunctor :: Any -> (a -> b)+anyToFunctor = unsafeCoerce+{-# INLINE anyToFunctor #-}++functorToAny :: (a -> b) -> Any+functorToAny = unsafeCoerce+{-# INLINE functorToAny #-}++-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+createArray+  :: Int+  -> a+  -> (forall s. MutableArray s a -> ST s ())+  -> Array a+createArray 0 _ _ = Array (emptyArray# (# #))+createArray n x f = runArray $ do+  mary <- newArray n x+  f mary+  pure mary++emptyArray# :: (# #) -> Array# a+emptyArray# _ = case emptyArray of Array ar -> ar+{-# NOINLINE emptyArray# #-}++emptyArray :: Array a+emptyArray =+  runST $ newArray 0 (error "impossible") >>= unsafeFreezeArray+{-# NOINLINE emptyArray #-}++createSmallArray ::+     Int+  -> a+  -> (forall s. SmallMutableArray s a -> ST s ())+  -> SmallArray a+createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #))+createSmallArray n x f = runSmallArray $ do+  mary <- newSmallArray n x+  f mary+  pure mary++emptySmallArray# :: (# #) -> SmallArray# a+emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar+{-# NOINLINE emptySmallArray# #-}++emptySmallArray :: SmallArray a+emptySmallArray = runST $ newSmallArray 0 (error "impossible") >>= unsafeFreezeSmallArray+{-# NOINLINE emptySmallArray #-}

@@ -1,7 +1,12 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}  -- | This provides an interface to working with boxed arrays -- with elements of type @Maybe a@. That is:@@ -20,28 +25,218 @@   , writeSmallMaybeArray   , sequenceSmallMaybeArray   , unsafeFreezeSmallMaybeArray+  , thawSmallMaybeArray+  , smallMaybeArrayFromList+  , smallMaybeArrayFromListN+  , sizeofSmallMaybeArray   ) where +import Prelude hiding (zipWith)+import Control.Applicative (Alternative(..), liftA2)+import Control.Monad (when, MonadPlus(..))+import Control.Monad.Fail (MonadFail(..))+import Control.Monad.ST (ST, runST)+import Control.Monad.Zip (MonadZip(..)) import Control.Monad.Primitive import Data.Primitive.SmallArray+import Data.Primitive.UnliftedArray (PrimUnlifted)+import Data.Data (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)+import Data.Function (fix)+import Data.Functor.Classes+import Data.Foldable hiding (toList)+import Data.Maybe (maybe)+import qualified Data.Foldable as Foldable -import Data.Primitive.Maybe.Internal (nothingSurrogate)-import GHC.Exts (Any,reallyUnsafePtrEquality#)+import Data.Primitive.Maybe.Internal+import GHC.Exts (Any,reallyUnsafePtrEquality#, IsList(..), SmallMutableArray#)+import Text.ParserCombinators.ReadP import Unsafe.Coerce (unsafeCoerce) +-- | An immutable array of boxed values of type @'Maybe' a@. newtype SmallMaybeArray a = SmallMaybeArray (SmallArray Any)+  deriving (PrimUnlifted)+-- | A mutable array of boxed values of type @'Maybe' a@. newtype SmallMutableMaybeArray s a = SmallMutableMaybeArray (SmallMutableArray s Any)+  deriving (PrimUnlifted)  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 #-}+infixl 1 ?+(?) :: (a -> b -> c) -> (b -> a -> c)+(?) = flip+{-# INLINE (?) #-} +instance Functor SmallMaybeArray where+  fmap f (SmallMaybeArray arr) = SmallMaybeArray $+    createSmallArray (sizeofSmallArray arr) nothingSurrogate $ \mb ->+      let go i+            | i == (sizeofSmallArray arr) = return ()+            | otherwise = do+                x <- indexSmallArrayM arr i+                case unsafeToMaybe x of+                  Nothing -> pure () +                  Just val -> writeSmallArray mb i (toAny (f val))+                go (i + 1)+      in go 0+  {-# INLINE fmap #-}+  x <$ SmallMaybeArray sa = SmallMaybeArray $ createSmallArray (length sa) (toAny x) (\ !_ -> pure ())++instance Applicative SmallMaybeArray where+  pure a = SmallMaybeArray $ createSmallArray 1 (toAny a) (\ !_ -> pure ())++  SmallMaybeArray sa *> SmallMaybeArray sb = SmallMaybeArray $ createSmallArray (la*lb) (error "impossible") $ \smb ->+    fix ? 0 $ \go i ->+      when (i < la) $+        copySmallArray smb 0 sb 0 lb *> go (i+1)+   where+   la = length sa ; lb = length sb+  +  SmallMaybeArray a <* SmallMaybeArray b = SmallMaybeArray $ createSmallArray (sza*szb) (error "impossible") $ \ma ->+    let fill off i e = when (i < szb) $+                         writeSmallArray ma (off+i) e >> fill off (i+1) e+        go i = when (i < sza) $ do+                 x <- indexSmallArrayM a i+                 fill (i*szb) 0 x+                 go (i+1)+     in go 0+   where sza = sizeofSmallArray a ; szb = sizeofSmallArray b+  +  abm@(SmallMaybeArray ab) <*> am@(SmallMaybeArray a) = SmallMaybeArray $ createSmallArray (szab * sza) nothingSurrogate $ \mb ->+    let go1 i = when (i < szab) $ do+          case indexSmallMaybeArray abm i of+            Nothing -> pure ()+            Just f -> go2 (i * sza) f 0+          go1 (i + 1)+        go2 off f j = when (j < sza) $ do+          case indexSmallMaybeArray am j of+            Nothing -> pure ()+            Just v -> writeSmallArray mb (off + j) (toAny (f v))+          go2 off f (j + 1)+    in go1 0+      where szab = sizeofSmallArray ab; sza = sizeofSmallArray a++instance Traversable SmallMaybeArray where+  traverse = traverseSmallArray++traverseSmallArray :: Applicative f+  => (a -> f b)+  -> SmallMaybeArray a+  -> f (SmallMaybeArray b)+traverseSmallArray f =  \ !(SmallMaybeArray ary) ->+  let+    !len = sizeofSmallArray ary+    go !ix+      | ix == len = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary)+      | otherwise = let x = indexSmallArray ary ix+                    in case unsafeToMaybe x of+                      Nothing -> go (ix + 1)+                      Just v -> liftA2 (\b (STA m) -> STA $ \mary ->+                                          writeSmallArray (SmallMutableArray mary) ix (toAny b) >> m mary)+                                       (f v) (go (ix + 1))+  in if len == 0+       then pure mempty+       else SmallMaybeArray <$> runSTA len <$> go 0++newtype STA a = STA { _runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a) }++runSTA :: Int -> STA a -> SmallArray a+runSTA !sz = \(STA m) -> runST $ newArray_ sz >>= \ar -> m (msarray# ar)++msarray# :: SmallMutableArray s a -> SmallMutableArray# s a+msarray# (SmallMutableArray m) = m+{-# INLINE msarray# #-}++newArray_ :: Int -> ST s (SmallMutableArray s a)+newArray_ !n = newSmallArray n badTraverseValue++badTraverseValue :: a+badTraverseValue = error "traverse: bad indexing"++data ArrayStack a+  = PushArray !(SmallArray a) !(ArrayStack a)+  | EmptyStack++instance Monad SmallMaybeArray where+  return = pure+  (>>) = (*>)+  (SmallMaybeArray ary) >>= f = SmallMaybeArray $ collect 0 EmptyStack (la - 1)+    where+      la = sizeofSmallArray ary+      collect sz stk i+        | i < 0 = createSmallArray sz nothingSurrogate $ fill 0 stk+        | otherwise = let x = indexSmallArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> collect sz stk (i - 1)+                        Just v -> let (SmallMaybeArray sb) = f v+                                      lsb = sizeofSmallArray sb+                                  in if lsb == 0+                                       then collect sz stk (i - 1)+                                       else collect (sz + lsb) (PushArray sb stk) (i - 1)+      fill _ EmptyStack _ = return ()+      fill off (PushArray sb sbs) smb+        | let lsb = sizeofSmallArray sb+        = copySmallArray smb off sb 0 lsb+            *> fill (off + lsb) sbs smb++instance Alternative SmallMaybeArray where+  empty = mempty+  (<|>) = (<>)+  some a | sizeofSmallMaybeArray a == 0 = mempty+         | otherwise = error "some: infinite arrays are not well defined"+  many a | sizeofSmallMaybeArray a == 0 = pure []+         | otherwise = error "many: infinite arrays are not well defined"++instance MonadPlus SmallMaybeArray where+  mzero = empty+  mplus = (<|>)++instance MonadFail SmallMaybeArray where+  fail _ = empty++zipWith :: (a -> b -> c) -> SmallMaybeArray a -> SmallMaybeArray b -> SmallMaybeArray c+zipWith f (SmallMaybeArray aa) (SmallMaybeArray ab) = SmallMaybeArray $+  createSmallArray mn nothingSurrogate $ \mc ->+    let go i+          | i < mn = do+              x <- indexSmallArrayM aa i+              y <- indexSmallArrayM ab i+              let x' = unsafeToMaybe x+                  y' = unsafeToMaybe y+              case x' of+                Nothing -> go (i + 1)+                Just va -> case y' of+                  Nothing -> go (i + 1)+                  Just vb -> writeSmallArray mc i (toAny $ f va vb) >> go (i + 1)+          | otherwise = return ()+    in go 0+  where mn = sizeofSmallArray aa `min` sizeofSmallArray ab++instance MonadZip SmallMaybeArray where+  mzip aa ab = zipWith (,) aa ab+  mzipWith f aa ab = zipWith f aa ab+  munzip :: forall a b. SmallMaybeArray (a, b) -> (SmallMaybeArray a, SmallMaybeArray b)+  munzip (SmallMaybeArray aab) = runST $ do+    let sz = sizeofSmallArray aab+    ma_ <- newSmallArray sz nothingSurrogate :: ST s (SmallMutableArray s Any)+    mb_ <- newSmallArray sz nothingSurrogate :: ST s (SmallMutableArray s Any)+    let go :: forall s. Int -> SmallMutableArray s Any -> SmallMutableArray s Any -> ST s ()+        go i ma mb = if i < sz+          then do+            tab <- indexSmallArrayM aab i+            let (a, b) = fromAny tab+                a' = unsafeToMaybe a+                b' = unsafeToMaybe b+            maybe (pure ()) (writeSmallArray ma i) a'+            maybe (pure ()) (writeSmallArray mb i) b'+            go (i + 1) ma mb+          else return ()++    go 0 ma_ mb_+    (ma1, ma2) <- (,) <$> unsafeFreezeSmallArray ma_ <*> unsafeFreezeSmallArray mb_+    return (unsafeCoerce ma1, unsafeCoerce ma2) :: ST s (SmallMaybeArray a, SmallMaybeArray b)++-- | Create a new 'SmallMutableMaybeArray' of the given size and initialize all elements with the given 'Maybe' value. newSmallMaybeArray :: PrimMonad m => Int -> Maybe a -> m (SmallMutableMaybeArray (PrimState m) a) {-# INLINE newSmallMaybeArray #-} newSmallMaybeArray i ma = case ma of@@ -52,18 +247,160 @@     x <- newSmallArray i nothingSurrogate     return (SmallMutableMaybeArray x) +instance Foldable SmallMaybeArray where+  -- Note: we perform the array lookups eagerly so we won't+  -- create thunks to perform lookups even if GHC can't see+  -- that the folding function is strict.+  foldr f = \z !(SmallMaybeArray ary) ->+    let+      !sz = sizeofSmallArray ary+      go i+        | i == sz = z+        | otherwise = let !x = indexSmallArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> z+                        Just val -> f val (go (i + 1))+    in go 0+  {-# INLINE foldr #-}+  foldl f = \z !(SmallMaybeArray ary) ->+    let+      go i+        | i < 0 = z+        | otherwise = let !x = indexSmallArray ary i+                      in case unsafeToMaybe x of+                        Nothing -> z+                        Just val -> f (go (i - 1)) val+    in go (sizeofSmallArray ary - 1)+  {-# INLINE foldl #-}+  null (SmallMaybeArray a) = sizeofSmallArray a == 0+  {-# INLINE null #-}+  length (SmallMaybeArray a) = sizeofSmallArray a+  {-# INLINE length #-}+  sum = foldl' (+) 0+  {-# INLINE sum #-}+  product = foldl' (*) 1+  {-# INLINE product #-}++instance Semigroup (SmallMaybeArray a) where+  SmallMaybeArray a1 <> SmallMaybeArray a2 = SmallMaybeArray $+    createSmallArray (sza1 + sza2) nothingSurrogate $ \ma ->+      copySmallArray ma 0 a1 0 sza1 >> copySmallArray ma sza1 a2 0 sza2+    where+      sza1 = sizeofSmallArray a1; sza2 = sizeofSmallArray a2++instance Monoid (SmallMaybeArray a) where+  mempty = SmallMaybeArray emptySmallArray+  mappend = (<>)++instance IsList (SmallMaybeArray a) where+  type Item (SmallMaybeArray a) = a+  fromListN = smallMaybeArrayFromListN+  fromList  = smallMaybeArrayFromList+  toList    = Foldable.toList++smallMaybeArrayLiftEq :: (a -> b -> Bool) -> SmallMaybeArray a -> SmallMaybeArray b -> Bool+smallMaybeArrayLiftEq p (SmallMaybeArray sa1) (SmallMaybeArray sa2) = length sa1 == length sa2 && loop (length sa1 - 1)+  where+    loop i+      | i < 0 = True+      | otherwise = let x = unsafeToMaybe (indexSmallArray sa1 i)+                        y = unsafeToMaybe (indexSmallArray sa2 i)+                    in case x of+                      Nothing -> case y of+                        Nothing -> True && loop (i - 1)+                        _       -> False+                      Just x' -> case y of+                        Nothing -> False+                        Just y' -> p x' y' && loop (i - 1)+                    +instance Eq a => Eq (SmallMaybeArray a) where+  sma1 == sma2 = smallMaybeArrayLiftEq (==) sma1 sma2++instance Eq1 SmallMaybeArray where+  liftEq = smallMaybeArrayLiftEq++smallMaybeArrayLiftCompare :: (a -> b -> Ordering) -> SmallMaybeArray a -> SmallMaybeArray b -> Ordering+smallMaybeArrayLiftCompare elemCompare (SmallMaybeArray a1) (SmallMaybeArray a2) = loop 0+  where+    la1 = length a1+    la2 = length a2+    mn = la1 `min` la2+    loop i+      | i < mn = let x = unsafeToMaybe (indexSmallArray a1 i)+                     y = unsafeToMaybe (indexSmallArray a2 i)+                 in case x of+                   Nothing -> case y of+                     Nothing -> EQ `mappend` loop (i + 1)+                     _       -> LT+                   Just x' -> case y of+                     Nothing -> GT+                     Just y' -> elemCompare x' y' `mappend` loop (i + 1)+     | otherwise = compare la1 la2++instance Ord a => Ord (SmallMaybeArray a) where+  compare sma1 sma2 = smallMaybeArrayLiftCompare compare sma1 sma2++instance Ord1 SmallMaybeArray where+  liftCompare = smallMaybeArrayLiftCompare++smallMaybeArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallMaybeArray a -> ShowS+smallMaybeArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $+  showString "fromListN " . shows (length sa) . showString " "+    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)++listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS+listLiftShowsPrec _ sl _ = sl++instance Show1 SmallMaybeArray where+  liftShowsPrec = smallMaybeArrayLiftShowsPrec++instance Show a => Show (SmallMaybeArray a) where+  showsPrec p sa = smallMaybeArrayLiftShowsPrec showsPrec showList p sa++smallMaybeArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallMaybeArray a)+smallMaybeArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do+  () <$ string "fromListN"+  skipSpaces+  n <- readS_to_P reads+  skipSpaces+  l <- readS_to_P listReadsPrec+  return $ smallMaybeArrayFromListN n l++instance Read1 SmallMaybeArray where+  liftReadsPrec = smallMaybeArrayLiftReadsPrec++instance Read a => Read (SmallMaybeArray a) where+  readsPrec = smallMaybeArrayLiftReadsPrec readsPrec readList++smallMaybeArrayDataType :: DataType+smallMaybeArrayDataType = mkDataType "Data.Primitive.Array.Maybe.SmallMaybeArray" [fromListConstr]++fromListConstr :: Constr+fromListConstr = mkConstr smallMaybeArrayDataType "fromList" [] Prefix++instance Data a => Data (SmallMaybeArray a) where+  toConstr _ = fromListConstr+  dataTypeOf _ = smallMaybeArrayDataType+  gunfold k z c = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  gfoldl f z m = z fromList `f` toList m++-- | Get the 'Maybe' value at the given index out of a 'SmallMaybeArray'. indexSmallMaybeArray :: SmallMaybeArray a -> Int -> Maybe a {-# INLINE indexSmallMaybeArray #-} indexSmallMaybeArray (SmallMaybeArray a) ix =   let (# v #) = indexSmallArray## a ix    in unsafeToMaybe v +-- | Get the 'Maybe' value at the given index out of a 'SmallMutableMaybeArray'. 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) +-- | Write a 'Maybe' value to the given index of a 'SmallMutableMaybeArray'. writeSmallMaybeArray :: PrimMonad m => SmallMutableMaybeArray (PrimState m) a -> Int -> Maybe a -> m () {-# INLINE writeSmallMaybeArray #-} writeSmallMaybeArray (SmallMutableMaybeArray marr) ix ma = case ma of@@ -84,12 +421,51 @@     then       let (# v #) = indexSmallArray## a ix        in case reallyUnsafePtrEquality# v nothingSurrogate of-            0# -> True-            _  -> go (ix + 1)+            0# -> go (ix + 1)+            _ -> True     else False +-- | Convert a 'SmallMutableMaybeArray' to an immutable one without copying.+--   The array should not be modified after the conversion. unsafeFreezeSmallMaybeArray :: PrimMonad m => SmallMutableMaybeArray (PrimState m) a -> m (SmallMaybeArray a) {-# INLINE unsafeFreezeSmallMaybeArray #-} unsafeFreezeSmallMaybeArray (SmallMutableMaybeArray ma) = do   a <- unsafeFreezeSmallArray ma   return (SmallMaybeArray a)++-- | Create a 'SmallMutableMaybeArray' from a slice of an immutable array. This operation makes a copy of+--   the specified slice, so it is safe to use the immutable array afterward.+thawSmallMaybeArray+  :: PrimMonad m+  => SmallMaybeArray a -- ^ source+  -> Int -- ^ offset+  -> Int -- ^ length+  -> m (SmallMutableMaybeArray (PrimState m) a)+thawSmallMaybeArray (SmallMaybeArray a) off len =+  fmap SmallMutableMaybeArray (thawSmallArray a off len)++-- | Given the length of the list and a list of @a@, build a 'SmallMaybeArray' from the values in the list.+--   If the given 'Int' does not match the length of the list, this function calls 'error'. You should prefer+--   this to 'maybeArrayFromList' if the length of the list has already been computed.+smallMaybeArrayFromListN :: Int -> [a] -> SmallMaybeArray a+smallMaybeArrayFromListN n l = SmallMaybeArray $+  createSmallArray n+      (error "uninitialized element") $ \sma ->+  let go !ix [] = if ix == n+        then return ()+        else error "list length less than specified size"+      go !ix (x : xs) = if ix < n+        then do+          writeSmallArray sma ix (toAny x)+          go (ix+1) xs+        else error "list length greater than specified size"+  in go 0 l++-- | Given a list of @a@, build a 'SmallMaybeArray' from the values in the list.+smallMaybeArrayFromList :: [a] -> SmallMaybeArray a+smallMaybeArrayFromList l = smallMaybeArrayFromListN (length l) l++-- | Yield the size of the 'SmallMaybeArray'.+sizeofSmallMaybeArray :: SmallMaybeArray a -> Int+sizeofSmallMaybeArray (SmallMaybeArray a) = sizeofSmallArray a+{-# INLINE sizeofSmallMaybeArray #-}

@@ -1,2 +1,110 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeInType #-}+#endif++import qualified Data.Foldable as Foldable+import Data.Proxy (Proxy(..))+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif++import Control.Monad.Zip (MonadZip)+import Control.Monad (MonadPlus)+import Data.Primitive.Array.Maybe+import Data.Primitive.SmallArray.Maybe+import GHC.Exts (IsList(..))+import Data.Functor.Classes++import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.QuickCheck (Arbitrary,Arbitrary1,Gen)+import qualified Test.Tasty.QuickCheck as TQC+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Classes as QCC+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = do+  defaultMain $ testGroup "properties"+    [ testGroup "MaybeArray" $ lawsToTest <$> maybeArrayLaws+    , testGroup "SmallMaybeArray" $ lawsToTest <$> smallMaybeArrayLaws+    ]++makeArrayLaws :: forall (f :: * -> *) a.+     (Monad f, MonadPlus f, MonadZip f, Foldable f, Eq1 f, Ord1 f, Show1 f, Arbitrary1 f, Traversable f)+  => (Read (f a), Show (Item (f a)), Monoid (f a), Ord (f a), Arbitrary (f a), Show (f a))+  => (IsList (f a), Show (Item (f a)), Arbitrary (Item (f a)))+  => Proxy f+  -> Proxy (f a)+  -> [QCC.Laws]+makeArrayLaws pf pfa =+  [ QCC.eqLaws pfa+  , QCC.ordLaws pfa+  , QCC.monoidLaws pfa+  , QCC.showReadLaws pfa+  , QCC.isListLaws pfa+  , QCC.functorLaws pf+  , QCC.alternativeLaws pf+  , QCC.applicativeLaws pf+  , QCC.foldableLaws pf+  , QCC.monadLaws pf +  , QCC.monadPlusLaws pf+  , QCC.monadZipLaws pf+  , QCC.traversableLaws pf+  ]++maybeArrayLaws :: [QCC.Laws]+maybeArrayLaws = makeArrayLaws proxyM1 proxyM++smallMaybeArrayLaws :: [QCC.Laws]+smallMaybeArrayLaws = makeArrayLaws proxyS1 proxyS++proxyM :: Proxy (MaybeArray Int)+proxyM = Proxy++proxyM1 :: Proxy MaybeArray+proxyM1 = Proxy++proxyS :: Proxy (SmallMaybeArray Int)+proxyS = Proxy++proxyS1 :: Proxy SmallMaybeArray+proxyS1 = Proxy++lawsToTest :: QCC.Laws -> TestTree+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)++instance Arbitrary1 MaybeArray where+  liftArbitrary :: forall a. Gen a -> Gen (MaybeArray a) +  liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen :: Gen [a])+  liftShrink :: forall a. (a -> [a]) -> MaybeArray a -> [MaybeArray a]+  liftShrink shrf m = fmap maybeArrayFromList (fmap shrf (Foldable.toList m))++instance Arbitrary a => Arbitrary (MaybeArray a) where+  arbitrary = QC.arbitrary1+  shrink = QC.shrink1++instance Arbitrary1 SmallMaybeArray where+  liftArbitrary :: forall a. Gen a -> Gen (SmallMaybeArray a) +  liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen :: Gen [a])+  liftShrink :: forall a. (a -> [a]) -> SmallMaybeArray a -> [SmallMaybeArray a]+  liftShrink shrf m = fmap smallMaybeArrayFromList (fmap shrf (Foldable.toList m))++instance Arbitrary a => Arbitrary (SmallMaybeArray a) where+  arbitrary = QC.arbitrary1+  shrink = QC.shrink1+